Index: trunk/src/system/system.nw =================================================================== --- trunk/src/system/system.nw (revision 8775) +++ trunk/src/system/system.nw (revision 8776) @@ -1,4868 +1,4831 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: system interfaces \chapter{System: Interfaces and Handlers} \includemodulegraph{system} Here, we collect modules that deal with the ``system'': operating-system interfaces, error handlers and diagnostics. \begin{description} \item[system\_defs] Constants relevant for the modules in this set. \item[diagnostics] Error and diagnostic message handling. Any messages and errors issued by WHIZARD functions are handled by the subroutines in this module, if possible. \item[os\_interface] Execute system calls, build and link external object files and libraries. \item[cputime] Timer data type and methods, for measuring performance. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Constants} The parameters here are used in various parts of the program, starting from the modules in the current chapter. Some of them may be modified if the need arises. <<[[system_defs.f90]]>>= <> module system_defs use, intrinsic :: iso_fortran_env, only: iostat_end, iostat_eor !NODEP! <> <> end module system_defs @ %def system_defs @ \subsection{Version} The version string is used for checking files. Note that the string length MUST NOT be changed, because reading binary files relies on it. <>= integer, parameter, public :: VERSION_STRLEN = 255 character(len=VERSION_STRLEN), parameter, public :: & & VERSION_STRING = "WHIZARD version <> (<>)" @ %def VERSION_STRLEN VERSION_STRING @ \subsection{Text Buffer} There is a hard limit on the line length which we should export. This buffer size is used both by the message handler, the lexer, and some further modules. <>= integer, parameter, public :: BUFFER_SIZE = 1000 @ %def BUFFER_SIZE @ \subsection{IOSTAT Codes} Defined in [[iso_fortran_env]], but we would like to use shorthands. <>= integer, parameter, public :: EOF = iostat_end, EOR = iostat_eor @ %def EOF EOR @ \subsection{Character Codes} Single-character constants. <>= character, parameter, public :: BLANK = ' ' character, parameter, public :: TAB = achar(9) character, parameter, public :: CR = achar(13) character, parameter, public :: LF = achar(10) character, parameter, public :: BACKSLASH = achar(92) @ %def BLANK TAB CR NL @ Character strings that indicate character classes. <>= character(*), parameter, public :: WHITESPACE_CHARS = BLANK// TAB // CR // LF character(*), parameter, public :: LCLETTERS = "abcdefghijklmnopqrstuvwxyz" character(*), parameter, public :: UCLETTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" character(*), parameter, public :: DIGITS = "0123456789" @ %def WHITESPACE_CHARS LCLETTERS UCLETTERS DIGITS @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{C wrapper for sigaction} This implements calls to [[sigaction]] and the appropriate signal handlers in C. The functionality is needed for the [[diagnostics]] module. <<[[signal_interface.c]]>>= /* <> */ #include #include extern int wo_sigint; extern int wo_sigterm; extern int wo_sigxcpu; extern int wo_sigxfsz; static void wo_handler_sigint (int sig) { wo_sigint = sig; } static void wo_handler_sigterm (int sig) { wo_sigterm = sig; } static void wo_handler_sigxcpu (int sig) { wo_sigxcpu = sig; } static void wo_handler_sigxfsz (int sig) { wo_sigxfsz = sig; } int wo_mask_sigint () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigint; return sigaction(SIGINT, &sa, NULL); } int wo_mask_sigterm () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigterm; return sigaction(SIGTERM, &sa, NULL); } int wo_mask_sigxcpu () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigxcpu; return sigaction(SIGXCPU, &sa, NULL); } int wo_mask_sigxfsz () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigxfsz; return sigaction(SIGXFSZ, &sa, NULL); } int wo_release_sigint () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGINT, &sa, NULL); } int wo_release_sigterm () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGTERM, &sa, NULL); } int wo_release_sigxcpu () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGXCPU, &sa, NULL); } int wo_release_sigxfsz () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGXFSZ, &sa, NULL); } @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{C wrapper for printf} The [[printf]] family of functions is implemented in C with an undefined number of arguments. This is not supported by the [[bind(C)]] interface. We therefore write wrappers for the versions of [[sprintf]] that we will actually use. This is used by the [[formats]] module. <<[[sprintf_interface.c]]>>= /* <> */ #include int sprintf_none(char* str, const char* format) { return sprintf(str, format); } int sprintf_int(char* str, const char* format, int val) { return sprintf(str, format, val); } int sprintf_double(char* str, const char* format, double val) { return sprintf(str, format, val); } int sprintf_str(char* str, const char* format, const char* val) { return sprintf(str, format, val); } <>= interface function sprintf_none (str, fmt) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt end function sprintf_none end interface interface function sprintf_int (str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt integer(c_int), value :: val end function sprintf_int end interface interface function sprintf_double (str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt real(c_double), value :: val end function sprintf_double end interface interface function sprintf_str(str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt character(c_char), dimension(*), intent(in) :: val end function sprintf_str end interface @ %def sprintf_int sprintf_double sprintf_str @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Error, Message and Signal Handling} We are not so ambitious as to do proper exception handling in [[WHIZARD]], but at least it may be useful to have a common interface for diagnostics: Results, messages, warnings, and such. As module variables we keep a buffer where the current message may be written to and a level indicator which tells which messages should be written on screen and which ones should be skipped. Alternatively, a string may be directly supplied to the message routine: this overrides the buffer, avoiding the necessety of formatted I/O in trivial cases. <<[[diagnostics.f90]]>>= <> module diagnostics use, intrinsic :: iso_c_binding !NODEP! <> <> use system_defs, only: BUFFER_SIZE, MAX_ERRORS <> <> <> <> <> <> interface <> end interface end module diagnostics <> @ %def diagnostics @ <<[[diagnostics_sub.f90]]>>= <> submodule (diagnostics) diagnostics_s use, intrinsic :: iso_fortran_env, only: output_unit !NODEP! use system_dependencies <> use string_utils, only: str use io_units implicit none contains <> end submodule diagnostics_s @ %def diagnostics_s @ Diagnostics levels: <>= public :: RESULT, DEBUG, DEBUG2 <>= integer, parameter :: TERMINATE=-2, BUG=-1, FATAL=1, & ERROR=2, WARNING=3, MESSAGE=4, RESULT=5, & DEBUG=6, DEBUG2=7 @ %def FATAL ERROR WARNING MESSAGE RESULT DEBUG DEBUG2 Diagnostics areas: <>= public :: d_area <>= interface d_area module procedure d_area_of_string module procedure d_area_to_string end interface <>= module function d_area_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string end function d_area_of_string elemental module function d_area_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i end function d_area_to_string <>= module function d_area_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string select case (char (string)) case ("particles") i = D_PARTICLES case ("events") i = D_EVENTS case ("shower") i = D_SHOWER case ("model_features") i = D_MODEL_F case ("matching") i = D_MATCHING case ("transforms") i = D_TRANSFORMS case ("subtraction") i = D_SUBTRACTION case ("virtual") i = D_VIRTUAL case ("threshold") i = D_THRESHOLD case ("phasespace") i = D_PHASESPACE case ("mismatch") i = D_MISMATCH case ("me_methods") i = D_ME_METHODS case ("process_integration") i = D_PROCESS_INTEGRATION case ("tauola") i = D_TAUOLA case ("core") i = D_CORE case ("vamp2") i = D_VAMP2 case ("mpi") i = D_MPI case ("qft") i = D_QFT case ("beams") i = D_BEAMS case ("real") i = D_REAL case ("flavor") i = D_FLAVOR case ("all") i = D_ALL case default print "(A)", "Possible values for --debug are:" do i = 0, D_LAST print "(A)", char (' ' // d_area_to_string(i)) end do call msg_fatal ("Please use one of the listed areas") end select end function d_area_of_string elemental module function d_area_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i select case (i) case (D_PARTICLES) string = "particles" case (D_EVENTS) string = "events" case (D_SHOWER) string = "shower" case (D_MODEL_F) string = "model_features" case (D_MATCHING) string = "matching" case (D_TRANSFORMS) string = "transforms" case (D_SUBTRACTION) string = "subtraction" case (D_VIRTUAL) string = "virtual" case (D_THRESHOLD) string = "threshold" case (D_PHASESPACE) string = "phasespace" case (D_MISMATCH) string = "mismatch" case (D_ME_METHODS) string = "me_methods" case (D_PROCESS_INTEGRATION) string = "process_integration" case (D_TAUOLA) string = "tauola" case (D_CORE) string = "core" case (D_VAMP2) string = "vamp2" case (D_MPI) string = "mpi" case (D_QFT) string = "qft" case (D_BEAMS) string = "beams" case (D_REAL) string = "real" case (D_FLAVOR) string = "flavor" case (D_ALL) string = "all" case default string = "undefined" end select end function d_area_to_string @ %def d_area @ <>= public :: D_PARTICLES, D_EVENTS, D_SHOWER, D_MODEL_F, & D_MATCHING, D_TRANSFORMS, D_SUBTRACTION, D_VIRTUAL, D_THRESHOLD, & D_PHASESPACE, D_MISMATCH, D_ME_METHODS, D_PROCESS_INTEGRATION, & D_TAUOLA, D_CORE, D_VAMP2, D_MPI, D_QFT, D_BEAMS, D_REAL, D_FLAVOR <>= integer, parameter :: D_ALL=0, D_PARTICLES=1, D_EVENTS=2, & D_SHOWER=3, D_MODEL_F=4, & D_MATCHING=5, D_TRANSFORMS=6, & D_SUBTRACTION=7, D_VIRTUAL=8, D_THRESHOLD=9, D_PHASESPACE=10, & D_MISMATCH=11, D_ME_METHODS=12, D_PROCESS_INTEGRATION=13, & D_TAUOLA=14, D_CORE=15, D_VAMP2 = 16, D_MPI = 17, D_QFT = 18, & D_BEAMS=19, D_REAL=20, D_FLAVOR=21, D_LAST=21 @ %def D_ALL D_PARTICLES D_EVENTS @ %def D_SHOWER D_MODEL_F D_MATCHING D_TRANSFORMS @ %def D_SUBTRACTION D_VIRTUAL D_THRESHOLD D_PHASESPACE @ %def D_MISMATCH D_ME_METHODS D_PROCESS_INTEGRATION @ %def D_TAUOLA D_CORE D_VAMP2 D_MPI D_QFT @ <>= public :: msg_level <>= integer, save, dimension(D_ALL:D_LAST) :: msg_level = RESULT @ %def msg_level @ <>= integer, parameter, public :: COL_UNDEFINED = -1 integer, parameter, public :: COL_GREY = 90, COL_PEACH = 91, COL_LIGHT_GREEN = 92, & COL_LIGHT_YELLOW = 93, COL_LIGHT_BLUE = 94, COL_PINK = 95, & COL_LIGHT_AQUA = 96, COL_PEARL_WHITE = 97, COL_BLACK = 30, & COL_RED = 31, COL_GREEN = 32, COL_YELLOW = 33, COL_BLUE = 34, & COL_PURPLE = 35, COL_AQUA = 36 @ %def COLORS @ <>= public :: set_debug_levels <>= module subroutine set_debug_levels (area_str) type(string_t), intent(in) :: area_str end subroutine set_debug_levels <>= module subroutine set_debug_levels (area_str) type(string_t), intent(in) :: area_str integer :: area if (.not. debug_on) call msg_fatal ("Debugging options & &can be used only if configured with --enable-fc-debug") area = d_area (area_str) if (area == D_ALL) then msg_level = DEBUG else msg_level(area) = DEBUG end if end subroutine set_debug_levels @ %def set_debug_levels @ <>= public :: set_debug2_levels <>= module subroutine set_debug2_levels (area_str) type(string_t), intent(in) :: area_str end subroutine set_debug2_levels <>= module subroutine set_debug2_levels (area_str) type(string_t), intent(in) :: area_str integer :: area if (.not. debug_on) call msg_fatal ("Debugging options & &can be used only if configured with --enable-fc-debug") area = d_area (area_str) if (area == D_ALL) then msg_level = DEBUG2 else msg_level(area) = DEBUG2 end if end subroutine set_debug2_levels @ %def set_debug2_levels @ <>= type :: terminal_color_t integer :: color = COL_UNDEFINED contains <> end type terminal_color_t @ %def terminal_color_t @ <>= public :: term_col <>= interface term_col module procedure term_col_int module procedure term_col_char end interface term_col @ %def term_col @ <>= module function term_col_int (col_int) result (color) type(terminal_color_t) :: color integer, intent(in) :: col_int end function term_col_int module function term_col_char (col_char) result (color) type(terminal_color_t) :: color character(len=*), intent(in) :: col_char end function term_col_char <>= module function term_col_int (col_int) result (color) type(terminal_color_t) :: color integer, intent(in) :: col_int color%color = col_int end function term_col_int module function term_col_char (col_char) result (color) type(terminal_color_t) :: color character(len=*), intent(in) :: col_char type(string_t) :: buf select case (col_char) case ('Grey') color%color = COL_GREY case ('Peach') color%color = COL_PEACH case ('Light Green') color%color = COL_LIGHT_GREEN case ('Light Yellow') color%color = COL_LIGHT_YELLOW case ('Light Blue') color%color = COL_LIGHT_BLUE case ('Pink') color%color = COL_PINK case ('Light Aqua') color%color = COL_LIGHT_AQUA case ('Pearl White') color%color = COL_PEARL_WHITE case ('Black') color%color = COL_BLACK case ('Red') color%color = COL_RED case ('Green') color%color = COL_GREEN case ('Yellow') color%color = COL_YELLOW case ('Blue') color%color = COL_BLUE case ('Purple') color%color = COL_PURPLE case ('Aqua') color%color = COL_AQUA case default buf = var_str ('Color ') // var_str (col_char) // var_str (' is not defined') call msg_warning (char (buf)) color%color = COL_UNDEFINED end select end function term_col_char @ %def term_col_int term_col_char @ Mask fatal errors so that are treated as normal errors. Useful for interactive mode. <>= public :: mask_fatal_errors <>= logical, save :: mask_fatal_errors = .false. @ %def mask_fatal_errors @ How to handle bugs and unmasked fatal errors. Either execute a normal stop statement, or call the C [[exit()]] function, or try to cause a program crash by dereferencing a null pointer. These procedures are appended to the [[diagnostics]] source code, but not as module procedures but as external procedures. This avoids a circular module dependency across source directories. <>= integer, parameter, public :: TERM_STOP = 0, TERM_EXIT = 1, TERM_CRASH = 2 @ %def TERM_STOP TERM_EXIT TERM_CRASH <>= public :: handle_fatal_errors <>= integer, save :: handle_fatal_errors = TERM_EXIT <>= subroutine fatal_force_crash () use diagnostics, only: handle_fatal_errors, TERM_CRASH !NODEP! implicit none handle_fatal_errors = TERM_CRASH end subroutine fatal_force_crash subroutine fatal_force_exit () use diagnostics, only: handle_fatal_errors, TERM_EXIT !NODEP! implicit none handle_fatal_errors = TERM_EXIT end subroutine fatal_force_exit subroutine fatal_force_stop () use diagnostics, only: handle_fatal_errors, TERM_STOP !NODEP! implicit none handle_fatal_errors = TERM_STOP end subroutine fatal_force_stop @ %def fatal_force_crash @ %def fatal_force_exit @ %def fatal_force_stop @ Keep track of errors. This might be used for exception handling, later. The counter is incremented only for screen messages, to avoid double counting. <>= public :: msg_count <>= integer, dimension(TERMINATE:WARNING), save :: msg_count = 0 @ %def msg_count @ Keep a list of all errors and warnings. Since we do not know the number of entries beforehand, we use a linked list. <>= type :: string_list character(len=BUFFER_SIZE) :: string type(string_list), pointer :: next end type string_list type :: string_list_pointer type(string_list), pointer :: first, last end type string_list_pointer @ %def string_list string_list_pointer <>= type(string_list_pointer), dimension(TERMINATE:WARNING), save :: & & msg_list = string_list_pointer (null(), null()) @ %def msg_list @ Create a format string indicating color @ Add the current message buffer contents to the internal list. <>= subroutine msg_add (level) integer, intent(in) :: level type(string_list), pointer :: message select case (level) case (TERMINATE:WARNING) allocate (message) message%string = msg_buffer nullify (message%next) if (.not.associated (msg_list(level)%first)) & & msg_list(level)%first => message if (associated (msg_list(level)%last)) & & msg_list(level)%last%next => message msg_list(level)%last => message msg_count(level) = msg_count(level) + 1 end select end subroutine msg_add @ %def msg_add @ Initialization: <>= public :: msg_list_clear <>= module subroutine msg_list_clear end subroutine msg_list_clear <>= module subroutine msg_list_clear integer :: level type(string_list), pointer :: message do level = TERMINATE, WARNING do while (associated (msg_list(level)%first)) message => msg_list(level)%first msg_list(level)%first => message%next deallocate (message) end do nullify (msg_list(level)%last) end do msg_count = 0 end subroutine msg_list_clear @ %def msg_list_clear @ Display the summary of errors and warnings (no need to count fatals\ldots) <>= public :: msg_summary <>= module subroutine msg_summary (unit) integer, intent(in), optional :: unit end subroutine msg_summary <>= module subroutine msg_summary (unit) integer, intent(in), optional :: unit call expect_summary (unit) 1 format (A,1x,I2,1x,A,I2,1x,A) if (msg_count(ERROR) > 0 .and. msg_count(WARNING) > 0) then write (msg_buffer, 1) "There were", & & msg_count(ERROR), "error(s) and ", & & msg_count(WARNING), "warning(s)." call msg_message (unit=unit) else if (msg_count(ERROR) > 0) then write (msg_buffer, 1) "There were", & & msg_count(ERROR), "error(s) and no warnings." call msg_message (unit=unit) else if (msg_count(WARNING) > 0) then write (msg_buffer, 1) "There were no errors and ", & & msg_count(WARNING), "warning(s)." call msg_message (unit=unit) end if end subroutine msg_summary @ %def msg_summary @ Print the list of all messages of a given level. <>= public :: msg_listing <>= module subroutine msg_listing (level, unit, prefix) integer, intent(in) :: level integer, intent(in), optional :: unit character(len=*), intent(in), optional :: prefix end subroutine msg_listing <>= module subroutine msg_listing (level, unit, prefix) integer, intent(in) :: level integer, intent(in), optional :: unit character(len=*), intent(in), optional :: prefix type(string_list), pointer :: message integer :: u u = given_output_unit (unit); if (u < 0) return if (present (unit)) u = unit message => msg_list(level)%first do while (associated (message)) if (present (prefix)) then write (u, "(A)") prefix // trim (message%string) else write (u, "(A)") trim (message%string) end if message => message%next end do flush (u) end subroutine msg_listing @ %def msg_listing @ The message buffer: <>= public :: msg_buffer <>= character(len=BUFFER_SIZE), save :: msg_buffer = " " @ %def msg_buffer @ After a message is issued, the buffer should be cleared: <>= subroutine buffer_clear msg_buffer = " " end subroutine buffer_clear @ %def buffer_clear <>= public :: create_col_string <>= module function create_col_string (color) result (col_string) type(string_t) :: col_string integer, intent(in) :: color end function create_col_string <>= module function create_col_string (color) result (col_string) type(string_t) :: col_string integer, intent(in) :: color character(2) :: buf write (buf, '(I2)') color col_string = var_str ("[") // var_str (buf) // var_str ("m") end function create_col_string @ %def create_col_string @ The generic handler for messages. If the unit is omitted (or $=6$), the message is written to standard output if the precedence if sufficiently high (as determined by the value of [[msg_level]]). If the string is omitted, the buffer is used. In any case, the buffer is cleared after printing. In accordance with FORTRAN custom, the first column in the output is left blank. For messages and warnings, an additional exclamation mark and a blank is prepended. Furthermore, each message is appended to the internal message list (without prepending anything). <>= subroutine message_print (level, string, str_arr, unit, logfile, area, color) integer, intent(in) :: level character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: str_arr integer, intent(in), optional :: unit logical, intent(in), optional :: logfile integer, intent(in), optional :: area integer, intent(in), optional :: color type(string_t) :: col_string, prep_string, aux_string, head_footer, app_string integer :: lu, i, ar logical :: severe, is_error ar = D_ALL; if (present (area)) ar = area severe = .false. head_footer = "******************************************************************************" aux_string = "" is_error = .false. app_string = "" select case (level) case (TERMINATE) prep_string = "" case (BUG) prep_string = "*** WHIZARD BUG: " aux_string = "*** " severe = .true. is_error = .true. case (FATAL) prep_string = "*** FATAL ERROR: " aux_string = "*** " severe = .true. is_error = .true. case (ERROR) prep_string = "*** ERROR: " aux_string = "*** " is_error = .true. case (WARNING) prep_string = "Warning: " case (MESSAGE) prep_string = "| " case (DEBUG, DEBUG2) prep_string = "D: " case default prep_string = "" end select if (present (color)) then if (color > COL_UNDEFINED) then col_string = create_col_string (color) prep_string = achar(27) // col_string // prep_string app_string = app_string // achar(27) // "[0m" end if end if if (present(string)) msg_buffer = string lu = log_unit if (present(unit)) then if (unit /= output_unit) then if (severe) write (unit, "(A)") char(head_footer) if (is_error) write (unit, "(A)") char(head_footer) write (unit, "(A,A,A)") char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) write (unit, "(A,A)") char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) write (unit, "(A)") char(head_footer) if (severe) write (unit, "(A)") char(head_footer) flush (unit) lu = -1 else if (level <= msg_level(ar)) then if (severe) print "(A)", char(head_footer) if (is_error) print "(A)", char(head_footer) print "(A,A,A)", char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) print "(A,A)", char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) print "(A)", char(head_footer) if (severe) print "(A)", char(head_footer) flush (output_unit) if (unit == log_unit) lu = -1 end if else if (level <= msg_level(ar)) then if (severe) print "(A)", char(head_footer) if (is_error) print "(A)", char(head_footer) print "(A,A,A)", char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) print "(A,A)", char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) print "(A)", char(head_footer) if (severe) print "(A)", char(head_footer) flush (output_unit) end if if (present (logfile)) then if (.not. logfile) lu = -1 end if if (logging .and. lu >= 0) then if (severe) write (lu, "(A)") char(head_footer) if (is_error) write (lu, "(A)") char(head_footer) write (lu, "(A,A,A)") char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) write (lu, "(A,A)") char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) write (lu, "(A)") char(head_footer) if (severe) write (lu, "(A)") char(head_footer) flush (lu) end if call msg_add (level) call buffer_clear end subroutine message_print @ %def message_print @ The number of non-fatal errors that we allow before stopping the program. We might trade this later for an adjustable number. <>= integer, parameter, public :: MAX_ERRORS = 10 @ %def MAX_ERRORS @ The specific handlers. In the case of fatal errors, bugs (failed assertions) and normal termination execution is stopped. For non-fatal errors a message is printed to standard output if no unit is given. Only if the number of [[MAX_ERRORS]] errors is reached, we abort the program. There are no further actions in the other cases, but this may change. <>= public :: msg_terminate public :: msg_bug, msg_fatal, msg_error, msg_warning public :: msg_message, msg_result <>= module subroutine msg_terminate (string, unit, quit_code) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string integer, intent(in), optional :: quit_code end subroutine msg_terminate module subroutine msg_bug (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr end subroutine msg_bug recursive module subroutine msg_fatal (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr end subroutine msg_fatal module subroutine msg_error (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr end subroutine msg_error module subroutine msg_warning (string, arr, unit, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr type(terminal_color_t), intent(in), optional :: color end subroutine msg_warning module subroutine msg_message (string, unit, arr, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color end subroutine msg_message module subroutine msg_result (string, arr, unit, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color end subroutine msg_result <>= module subroutine msg_terminate (string, unit, quit_code) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string integer, intent(in), optional :: quit_code integer(c_int) :: return_code call release_term_signals () if (present (quit_code)) then return_code = quit_code else return_code = 0 end if if (present (string)) & call message_print (MESSAGE, string, unit=unit) call msg_summary (unit) if (return_code == 0 .and. expect_failures /= 0) then return_code = 5 call message_print (MESSAGE, & "WHIZARD run finished with 'expect' failure(s).", unit=unit) else if (return_code == 7) then call message_print (MESSAGE, & "WHIZARD run finished with failed self-test.", unit=unit) else call message_print (MESSAGE, "WHIZARD run finished.", unit=unit) end if call message_print (0, & "|=============================================================================|", unit=unit) call logfile_final () call msg_list_clear () if (return_code /= 0) then call exit (return_code) else !!! Should implement WHIZARD exit code (currently only via C) call exit (0) end if end subroutine msg_terminate module subroutine msg_bug (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, pointer :: crash_ptr call message_print (BUG, string, arr, unit) call msg_summary (unit) select case (handle_fatal_errors) case (TERM_EXIT) call message_print (TERMINATE, "WHIZARD run aborted.", unit=unit) call exit (-1_c_int) case (TERM_CRASH) print *, "*** Intentional crash ***" crash_ptr => null () print *, crash_ptr end select stop "WHIZARD run aborted." end subroutine msg_bug recursive module subroutine msg_fatal (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, pointer :: crash_ptr if (mask_fatal_errors) then call msg_error (string, arr, unit) else call message_print (FATAL, string, arr, unit) call msg_summary (unit) select case (handle_fatal_errors) case (TERM_EXIT) call message_print (TERMINATE, "WHIZARD run aborted.", unit=unit) call exit (1_c_int) case (TERM_CRASH) print *, "*** Intentional crash ***" crash_ptr => null () print *, crash_ptr end select stop "WHIZARD run aborted." end if end subroutine msg_fatal module subroutine msg_error (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr call message_print (ERROR, string, arr, unit) if (msg_count(ERROR) >= MAX_ERRORS) then mask_fatal_errors = .false. call msg_fatal (" Too many errors encountered.") else if (.not.present(unit) .and. .not.mask_fatal_errors) then call message_print (MESSAGE, " (WHIZARD run continues)") end if end subroutine msg_error module subroutine msg_warning (string, arr, unit, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = WARNING, string = string, & str_arr = arr, unit = unit, color = cl) end subroutine msg_warning module subroutine msg_message (string, unit, arr, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = MESSAGE, & string = string, str_arr = arr, unit = unit, & logfile = logfile, color = cl) end subroutine msg_message module subroutine msg_result (string, arr, unit, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = RESULT, string = string, & str_arr = arr, unit = unit, logfile = logfile, color = cl) end subroutine msg_result @ %def msg_warning msg_message msg_result @ Debugging aids. Print messages or values of various kinds. All versions ultimately call [[msg_debug_none]], which in turn uses [[message_print]]. Safeguard: force crash if a routine (i.e., a debugging routine below) is called while the master switch [[debug_on]] is unset. Such calls should always be hidden behind [[if (debug_on)]], since they can significantly slow down the program. <>= if (.not. debug_on) call msg_bug ("msg_debug called with debug_on=.false.") @ The [[debug_on]] flag is provided by the [[debug_master]] module, and we can assume that it is a compile-time parameter. <>= public :: msg_debug <>= interface msg_debug module procedure msg_debug_none module procedure msg_debug_logical module procedure msg_debug_integer module procedure msg_debug_real module procedure msg_debug_complex module procedure msg_debug_string end interface <>= module subroutine msg_debug_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_none module subroutine msg_debug_logical (area, string, value, color) logical, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_logical module subroutine msg_debug_integer (area, string, value, color) integer, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_integer module subroutine msg_debug_real (area, string, value, color) real(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_real module subroutine msg_debug_complex (area, string, value, color) complex(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_complex module subroutine msg_debug_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_string <>= module subroutine msg_debug_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color integer :: cl if (debug_active (area)) then cl = COL_BLUE; if (present (color)) cl = color%color call message_print (DEBUG, string, unit = output_unit, & area = area, logfile = .false., color = cl) else <> end if end subroutine msg_debug_none module subroutine msg_debug_logical (area, string, value, color) logical, intent(in) :: value <> end subroutine msg_debug_logical module subroutine msg_debug_integer (area, string, value, color) integer, intent(in) :: value <> end subroutine msg_debug_integer module subroutine msg_debug_real (area, string, value, color) real(default), intent(in) :: value <> end subroutine msg_debug_real module subroutine msg_debug_complex (area, string, value, color) complex(default), intent(in) :: value <> end subroutine msg_debug_complex module subroutine msg_debug_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color if (debug_active (area)) then call msg_debug_none (area, string // " = " // char (value), & color = color) else <> end if end subroutine msg_debug_string @ %def msg_debug <>= integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color character(len=64) :: buffer if (debug_active (area)) then write (buffer, *) value call msg_debug_none (area, string // " = " // trim (buffer), & color = color) else <> end if @ <>= public :: msg_print_color <>= interface msg_print_color module procedure msg_print_color_none module procedure msg_print_color_logical module procedure msg_print_color_integer module procedure msg_print_color_real end interface <>= module subroutine msg_print_color_none (string, color) character(len=*), intent(in) :: string !!!type(terminal_color_t), intent(in) :: color integer, intent(in) :: color end subroutine msg_print_color_none module subroutine msg_print_color_logical (string, value, color) character(len=*), intent(in) :: string logical, intent(in) :: value integer, intent(in) :: color end subroutine msg_print_color_logical module subroutine msg_print_color_integer (string, value, color) character(len=*), intent(in) :: string integer, intent(in) :: value integer, intent(in) :: color end subroutine msg_print_color_integer module subroutine msg_print_color_real (string, value, color) character(len=*), intent(in) :: string real(default), intent(in) :: value integer, intent(in) :: color end subroutine msg_print_color_real <>= module subroutine msg_print_color_none (string, color) character(len=*), intent(in) :: string !!!type(terminal_color_t), intent(in) :: color integer, intent(in) :: color call message_print (0, string, color = color) end subroutine msg_print_color_none module subroutine msg_print_color_logical (string, value, color) character(len=*), intent(in) :: string logical, intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_logical module subroutine msg_print_color_integer (string, value, color) character(len=*), intent(in) :: string integer, intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_integer module subroutine msg_print_color_real (string, value, color) character(len=*), intent(in) :: string real(default), intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_real @ %def msg_print_color_none, msg_print_color_logical @ %def msg_print_color_integer, msg_print_color_real @ Secondary debugging aids which implement more fine-grained debugging. Again, there is a safeguard against calling anything while [[debug_on=.false.]]. <>= if (.not. debug_on) call msg_bug ("msg_debug2 called with debug_on=.false.") <>= public :: msg_debug2 <>= interface msg_debug2 module procedure msg_debug2_none module procedure msg_debug2_logical module procedure msg_debug2_integer module procedure msg_debug2_real module procedure msg_debug2_complex module procedure msg_debug2_string end interface <>= module subroutine msg_debug2_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_none module subroutine msg_debug2_logical (area, string, value, color) logical, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_logical module subroutine msg_debug2_integer (area, string, value, color) integer, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_integer module subroutine msg_debug2_real (area, string, value, color) real(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_real module subroutine msg_debug2_complex (area, string, value, color) complex(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_complex module subroutine msg_debug2_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_string <>= module subroutine msg_debug2_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color integer :: cl if (debug2_active (area)) then cl = COL_BLUE; if (present (color)) cl = color%color call message_print (DEBUG2, string, unit = output_unit, & area = area, logfile = .false., color = cl) else <> end if end subroutine msg_debug2_none module subroutine msg_debug2_logical (area, string, value, color) logical, intent(in) :: value <> end subroutine msg_debug2_logical module subroutine msg_debug2_integer (area, string, value, color) integer, intent(in) :: value <> end subroutine msg_debug2_integer module subroutine msg_debug2_real (area, string, value, color) real(default), intent(in) :: value <> end subroutine msg_debug2_real module subroutine msg_debug2_complex (area, string, value, color) complex(default), intent(in) :: value <> end subroutine msg_debug2_complex module subroutine msg_debug2_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color if (debug2_active (area)) then call msg_debug2_none (area, string // " = " // char (value), & color = color) else <> end if end subroutine msg_debug2_string @ %def msg_debug2 <>= integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color character(len=64) :: buffer if (debug2_active (area)) then write (buffer, *) value call msg_debug2_none (area, string // " = " // trim (buffer), & color = color) else <> end if @ <>= public :: debug_active <>= elemental module function debug_active (area) result (active) logical :: active integer, intent(in) :: area end function debug_active <>= elemental module function debug_active (area) result (active) logical :: active integer, intent(in) :: area active = debug_on .and. msg_level(area) >= DEBUG end function debug_active @ %def debug_active @ <>= public :: debug2_active <>= elemental module function debug2_active (area) result (active) logical :: active integer, intent(in) :: area end function debug2_active <>= elemental module function debug2_active (area) result (active) logical :: active integer, intent(in) :: area active = debug_on .and. msg_level(area) >= DEBUG2 end function debug2_active @ %def debug2_active @ Show the progress of a loop in steps of 10 \%. Could be generalized to other step sizes with an optional argument. <>= public :: msg_show_progress <>= module subroutine msg_show_progress (i_call, n_calls) integer, intent(in) :: i_call, n_calls end subroutine msg_show_progress <>= module subroutine msg_show_progress (i_call, n_calls) integer, intent(in) :: i_call, n_calls real(default) :: progress integer, save :: next_check if (i_call == 1) next_check = 10 progress = (i_call * 100._default) / n_calls if (progress >= next_check) then write (msg_buffer, "(F5.1,A)") progress, "%" call msg_message () next_check = next_check + 10 end if end subroutine msg_show_progress @ %def msg_show_progress @ Interface to the standard clib exit function <>= public :: exit <>= interface subroutine exit (status) bind (C) use iso_c_binding !NODEP! integer(c_int), value :: status end subroutine exit end interface @ %def exit @ Print the WHIZARD banner: <>= public :: msg_banner <>= module subroutine msg_banner (unit) integer, intent(in), optional :: unit end subroutine msg_banner <>= module subroutine msg_banner (unit) integer, intent(in), optional :: unit call message_print (0, "|=============================================================================|", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| WW WW WW WW WW WWWWWW WW WWWWW WWWW |", unit=unit) call message_print (0, "| WW WW WW WW WW WW WW WWWW WW WW WW WW |", unit=unit) call message_print (0, "| WW WW WW WW WWWWWWW WW WW WW WW WWWWW WW WW |", unit=unit) call message_print (0, "| WWWW WWWW WW WW WW WW WWWWWWWW WW WW WW WW |", unit=unit) call message_print (0, "| WW WW WW WW WW WWWWWW WW WW WW WW WWWW |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| W |", unit=unit) call message_print (0, "| sW |", unit=unit) call message_print (0, "| WW |", unit=unit) call message_print (0, "| sWW |", unit=unit) call message_print (0, "| WWW |", unit=unit) call message_print (0, "| wWWW |", unit=unit) call message_print (0, "| wWWWW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| wWW WW |", unit=unit) call message_print (0, "| wWW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| wwwwww WW WW |", unit=unit) call message_print (0, "| WWWWWww WW WW |", unit=unit) call message_print (0, "| WWWWWwwwww WW WW |", unit=unit) call message_print (0, "| wWWWwwwwwWW WW |", unit=unit) call message_print (0, "| wWWWWWWWWWWwWWW WW |", unit=unit) call message_print (0, "| wWWWWW wW WWWWWWW |", unit=unit) call message_print (0, "| WWWW wW WW wWWWWWWWwww |", unit=unit) call message_print (0, "| WWWW wWWWWWWWwwww |", unit=unit) call message_print (0, "| WWWW WWWW WWw |", unit=unit) call message_print (0, "| WWWWww WWWW |", unit=unit) call message_print (0, "| WWWwwww WWWW |", unit=unit) call message_print (0, "| wWWWWwww wWWWWW |", unit=unit) call message_print (0, "| WwwwwwwwwWWW |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| by: Wolfgang Kilian, Thorsten Ohl, Juergen Reuter |", unit=unit) call message_print (0, "| with contributions from Christian Speckner |", unit=unit) call message_print (0, "| Contact: |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| if you use WHIZARD please cite: |", unit=unit) call message_print (0, "| W. Kilian, T. Ohl, J. Reuter, Eur.Phys.J.C71 (2011) 1742 |", unit=unit) call message_print (0, "| [arXiv: 0708.4233 [hep-ph]] |", unit=unit) call message_print (0, "| M. Moretti, T. Ohl, J. Reuter, arXiv: hep-ph/0102195 |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "|=============================================================================|", unit=unit) call message_print (0, "| WHIZARD " // WHIZARD_VERSION, unit=unit) call message_print (0, "|=============================================================================|", unit=unit) end subroutine msg_banner @ %def msg_banner @ \subsection{Logfile} All screen output should be duplicated in the logfile, unless requested otherwise. <>= public :: logging <>= integer, save :: log_unit = -1 logical, target, save :: logging = .false. <>= public :: logfile_init <>= module subroutine logfile_init (filename) type(string_t), intent(in) :: filename end subroutine logfile_init <>= module subroutine logfile_init (filename) type(string_t), intent(in) :: filename call msg_message ("Writing log to '" // char (filename) // "'") if (.not. logging) call msg_message ("(Logging turned off.)") log_unit = free_unit () open (file = char (filename), unit = log_unit, & action = "write", status = "replace") end subroutine logfile_init @ %def logfile_init <>= public :: logfile_final <>= module subroutine logfile_final () end subroutine logfile_final <>= module subroutine logfile_final () if (log_unit >= 0) then close (log_unit) log_unit = -1 end if end subroutine logfile_final @ %def logfile_final @ This returns the valid logfile unit only if the default is write to screen, and if [[logfile]] is not set false. <>= public :: logfile_unit <>= module function logfile_unit (unit, logfile) integer :: logfile_unit integer, intent(in), optional :: unit logical, intent(in), optional :: logfile end function logfile_unit <>= module function logfile_unit (unit, logfile) integer :: logfile_unit integer, intent(in), optional :: unit logical, intent(in), optional :: logfile if (logging) then if (present (unit)) then if (unit == output_unit) then logfile_unit = log_unit else logfile_unit = -1 end if else if (present (logfile)) then if (logfile) then logfile_unit = log_unit else logfile_unit = -1 end if else logfile_unit = log_unit end if else logfile_unit = -1 end if end function logfile_unit @ %def logfile_unit @ \subsection{Checking values} The [[expect]] function does not just check a value for correctness (actually, it checks if a logical expression is true); it records its result here. If failures are present when the program terminates, the exit code is nonzero. <>= integer, save :: expect_total = 0 integer, save :: expect_failures = 0 @ %def expect_total expect_failures <>= public :: expect_record <>= module subroutine expect_record (success) logical, intent(in) :: success end subroutine expect_record <>= module subroutine expect_record (success) logical, intent(in) :: success expect_total = expect_total + 1 if (.not. success) expect_failures = expect_failures + 1 end subroutine expect_record @ %def expect_record <>= public :: expect_clear <>= module subroutine expect_clear () end subroutine expect_clear <>= module subroutine expect_clear () expect_total = 0 expect_failures = 0 end subroutine expect_clear @ %def expect_clear <>= public :: expect_summary <>= module subroutine expect_summary (unit, force) integer, intent(in), optional :: unit logical, intent(in), optional :: force end subroutine expect_summary <>= module subroutine expect_summary (unit, force) integer, intent(in), optional :: unit logical, intent(in), optional :: force logical :: force_output force_output = .false.; if (present (force)) force_output = force if (expect_total /= 0 .or. force_output) then call msg_message ("Summary of value checks:", unit) write (msg_buffer, "(2x,A,1x,I0,1x,A,1x,A,1x,I0)") & "Failures:", expect_failures, "/", "Total:", expect_total call msg_message (unit=unit) end if end subroutine expect_summary @ %def expect_summary @ Helpers for converting integers into strings with minimal length. <>= public :: int2string public :: int2char public :: int2fixed <>= pure module function int2fixed (i) result (c) integer, intent(in) :: i character(200) :: c end function int2fixed pure module function int2string (i) result (s) integer, intent(in) :: i type (string_t) :: s end function int2string pure module function int2char (i) result (c) integer, intent(in) :: i character(len (trim (int2fixed (i)))) :: c end function int2char <>= pure module function int2fixed (i) result (c) integer, intent(in) :: i character(200) :: c c = "" write (c, *) i c = adjustl (c) end function int2fixed pure module function int2string (i) result (s) integer, intent(in) :: i type (string_t) :: s s = trim (int2fixed (i)) end function int2string pure module function int2char (i) result (c) integer, intent(in) :: i character(len (trim (int2fixed (i)))) :: c c = int2fixed (i) end function int2char @ %def int2fixed int2string int2char @ Dito for reals. <>= public :: real2string public :: real2char public :: real2fixed <>= interface real2string module procedure real2string_list, real2string_fmt end interface interface real2char module procedure real2char_list, real2char_fmt end interface <>= pure module function real2fixed (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in), optional :: fmt character(200) :: c end function real2fixed pure module function real2fixed_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(200) :: c end function real2fixed_fmt pure module function real2string_list (x) result (s) real(default), intent(in) :: x type(string_t) :: s end function real2string_list pure module function real2string_fmt (x, fmt) result (s) real(default), intent(in) :: x character(*), intent(in) :: fmt type(string_t) :: s end function real2string_fmt pure module function real2char_list (x) result (c) real(default), intent(in) :: x character(len_trim (real2fixed (x))) :: c end function real2char_list pure module function real2char_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(len_trim (real2fixed_fmt (x, fmt))) :: c end function real2char_fmt <>= pure module function real2fixed (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in), optional :: fmt character(200) :: c c = "" write (c, *) x c = adjustl (c) end function real2fixed pure module function real2fixed_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(200) :: c c = "" write (c, fmt) x c = adjustl (c) end function real2fixed_fmt pure module function real2string_list (x) result (s) real(default), intent(in) :: x type(string_t) :: s s = trim (real2fixed (x)) end function real2string_list pure module function real2string_fmt (x, fmt) result (s) real(default), intent(in) :: x character(*), intent(in) :: fmt type(string_t) :: s s = trim (real2fixed_fmt (x, fmt)) end function real2string_fmt pure module function real2char_list (x) result (c) real(default), intent(in) :: x character(len_trim (real2fixed (x))) :: c c = real2fixed (x) end function real2char_list pure module function real2char_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(len_trim (real2fixed_fmt (x, fmt))) :: c c = real2fixed_fmt (x, fmt) end function real2char_fmt @ %def real2fixed real2string real2char @ Dito for complex values; we do not use the slightly ugly FORTRAN output form here but instead introduce our own. Ifort and Portland seem to have problems with this, therefore temporarily disable it. % <>= public :: cmplx2string public :: cmplx2char <>= pure function cmplx2string (x) result (s) complex(default), intent(in) :: x type(string_t) :: s s = real2string (real (x, default)) if (aimag (x) /= 0) s = s // " + " // real2string (aimag (x)) // " I" end function cmplx2string pure function cmplx2char (x) result (c) complex(default), intent(in) :: x character(len (char (cmplx2string (x)))) :: c c = char (cmplx2string (x)) end function cmplx2char @ %def cmplx2string cmplx2char @ -\subsection{Suppression of numerical noise} -<>= - public :: pacify -<>= - interface pacify - module procedure pacify_real_default - module procedure pacify_complex_default - end interface pacify - -<>= - elemental module subroutine pacify_real_default (x, tolerance) - real(default), intent(inout) :: x - real(default), intent(in) :: tolerance - end subroutine pacify_real_default - - elemental module subroutine pacify_complex_default (x, tolerance) - complex(default), intent(inout) :: x - real(default), intent(in) :: tolerance - end subroutine pacify_complex_default -<>= - elemental module subroutine pacify_real_default (x, tolerance) - real(default), intent(inout) :: x - real(default), intent(in) :: tolerance - if (abs (x) < tolerance) x = 0._default - end subroutine pacify_real_default - - elemental module subroutine pacify_complex_default (x, tolerance) - complex(default), intent(inout) :: x - real(default), intent(in) :: tolerance - if (abs (real (x)) < tolerance) & - x = cmplx (0._default, aimag (x), kind=default) - if (abs (aimag (x)) < tolerance) & - x = cmplx (real (x), 0._default, kind=default) - end subroutine pacify_complex_default - -@ %def pacify -@ \subsection{Signal handling} Killing the program by external signals may leave the files written by it in an undefined state. This can be avoided by catching signals and deferring program termination. Instead of masking only critical sections, we choose to mask signals globally (done in the main program) and terminate the program at predefined checkpoints only. Checkpoints are after each command, within the sampling function (so the program can be terminated after each event), and after each iteration in the phase-space generation algorithm. Signal handling is done via a C interface to the [[sigaction]] system call. When a signal is raised that has been masked by the handler, the corresponding variable is set to the value of the signal. The variables are visible from the C signal handler. The signal SIGINT is for keyboard interrupt (ctrl-C), SIGTERM is for system interrupt, e.g., at shutdown. The SIGXCPU and SIGXFSZ signals may be issued by batch systems. <>= public :: wo_sigint public :: wo_sigterm public :: wo_sigxcpu public :: wo_sigxfsz <>= integer(c_int), bind(C), volatile :: wo_sigint = 0 integer(c_int), bind(C), volatile :: wo_sigterm = 0 integer(c_int), bind(C), volatile :: wo_sigxcpu = 0 integer(c_int), bind(C), volatile :: wo_sigxfsz = 0 @ %def wo_sigint wo_sigterm wo_sigxcpu wo_sigxfsz @ Here are the interfaces to the C functions. The routine [[mask_term_signals]] forces termination signals to be delayed. [[release_term_signals]] restores normal behavior. However, the program can be terminated anytime by calling [[terminate_now_if_signal]] which inspects the signals and terminates the program if requested.. <>= public :: mask_term_signals <>= module subroutine mask_term_signals () end subroutine mask_term_signals <>= module subroutine mask_term_signals () logical :: ok wo_sigint = 0 ok = wo_mask_sigint () == 0 if (.not. ok) call msg_error ("Masking SIGINT failed") wo_sigterm = 0 ok = wo_mask_sigterm () == 0 if (.not. ok) call msg_error ("Masking SIGTERM failed") wo_sigxcpu = 0 ok = wo_mask_sigxcpu () == 0 if (.not. ok) call msg_error ("Masking SIGXCPU failed") wo_sigxfsz = 0 ok = wo_mask_sigxfsz () == 0 if (.not. ok) call msg_error ("Masking SIGXFSZ failed") end subroutine mask_term_signals @ %def mask_term_signals <>= interface integer(c_int) function wo_mask_sigint () bind(C) import end function wo_mask_sigint end interface interface integer(c_int) function wo_mask_sigterm () bind(C) import end function wo_mask_sigterm end interface interface integer(c_int) function wo_mask_sigxcpu () bind(C) import end function wo_mask_sigxcpu end interface interface integer(c_int) function wo_mask_sigxfsz () bind(C) import end function wo_mask_sigxfsz end interface @ %def wo_mask_sigint wo_mask_sigterm wo_mask_sigxcpu wo_mask_sigxfsz <>= public :: release_term_signals <>= module subroutine release_term_signals () end subroutine release_term_signals <>= module subroutine release_term_signals () logical :: ok ok = wo_release_sigint () == 0 if (.not. ok) call msg_error ("Releasing SIGINT failed") ok = wo_release_sigterm () == 0 if (.not. ok) call msg_error ("Releasing SIGTERM failed") ok = wo_release_sigxcpu () == 0 if (.not. ok) call msg_error ("Releasing SIGXCPU failed") ok = wo_release_sigxfsz () == 0 if (.not. ok) call msg_error ("Releasing SIGXFSZ failed") end subroutine release_term_signals @ %def release_term_signals <>= interface integer(c_int) function wo_release_sigint () bind(C) import end function wo_release_sigint end interface interface integer(c_int) function wo_release_sigterm () bind(C) import end function wo_release_sigterm end interface interface integer(c_int) function wo_release_sigxcpu () bind(C) import end function wo_release_sigxcpu end interface interface integer(c_int) function wo_release_sigxfsz () bind(C) import end function wo_release_sigxfsz end interface @ %def wo_release_sigint wo_release_sigterm @ %def wo_release_sigxcpu wo_release_sigxfsz <>= public :: signal_is_pending <>= module function signal_is_pending () result (flag) logical :: flag end function signal_is_pending <>= module function signal_is_pending () result (flag) logical :: flag flag = & wo_sigint /= 0 .or. & wo_sigterm /= 0 .or. & wo_sigxcpu /= 0 .or. & wo_sigxfsz /= 0 end function signal_is_pending @ %def signal_is_pending <>= public :: terminate_now_if_signal <>= module subroutine terminate_now_if_signal () end subroutine terminate_now_if_signal <>= module subroutine terminate_now_if_signal () if (wo_sigint /= 0) then call msg_terminate ("Signal SIGINT (keyboard interrupt) received.", & quit_code=int (wo_sigint)) else if (wo_sigterm /= 0) then call msg_terminate ("Signal SIGTERM (termination signal) received.", & quit_code=int (wo_sigterm)) else if (wo_sigxcpu /= 0) then call msg_terminate ("Signal SIGXCPU (CPU time limit exceeded) received.", & quit_code=int (wo_sigxcpu)) else if (wo_sigxfsz /= 0) then call msg_terminate ("Signal SIGXFSZ (file size limit exceeded) received.", & quit_code=int (wo_sigxfsz)) end if end subroutine terminate_now_if_signal @ %def terminate_now_if_signal @ <>= public :: single_event <>= logical :: single_event = .false. @ <>= public :: terminate_now_if_single_event <>= module subroutine terminate_now_if_single_event () end subroutine terminate_now_if_single_event <>= module subroutine terminate_now_if_single_event () integer, save :: n_calls = 0 n_calls = n_calls + 1 if (single_event .and. n_calls > 1) then call msg_terminate ("Stopping after one event", quit_code=0) end if end subroutine terminate_now_if_single_event @ %def terminate_now_if_single_event @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Operating-system interface} For specific purposes, we need direct access to the OS (system calls). This is, of course, system dependent. The current version is valid for GNU/Linux; we expect to use a preprocessor for this module if different OSs are to be supported. The current implementation lacks error handling. <<[[os_interface.f90]]>>= <> module os_interface use, intrinsic :: iso_c_binding !NODEP! <> <> <> <> <> interface <> end interface end module os_interface @ %def os_interface @ <<[[os_interface_sub.f90]]>>= <> submodule (os_interface) os_interface_s use system_defs, only: DLERROR_LEN, ENVVAR_LEN use io_units use diagnostics use system_dependencies <> implicit none contains <> end submodule os_interface_s @ %def os_interface_s @ \subsection{Path variables} This is a transparent container for storing user-defined path variables. <>= public :: paths_t <>= type :: paths_t type(string_t) :: prefix type(string_t) :: exec_prefix type(string_t) :: bindir type(string_t) :: libdir type(string_t) :: includedir type(string_t) :: datarootdir type(string_t) :: localprefix type(string_t) :: libtool type(string_t) :: lhapdfdir end type paths_t @ %def paths_t <>= public :: paths_init <>= module subroutine paths_init (paths) type(paths_t), intent(out) :: paths end subroutine paths_init <>= module subroutine paths_init (paths) type(paths_t), intent(out) :: paths paths%prefix = "" paths%exec_prefix = "" paths%bindir = "" paths%libdir = "" paths%includedir = "" paths%datarootdir = "" paths%localprefix = "" paths%libtool = "" paths%lhapdfdir = "" end subroutine paths_init @ %def paths_init @ \subsection{System dependencies} We store all potentially system- and user/run-dependent data in a transparent container. This includes compiler/linker names and flags, file extensions, etc. There are actually two different possibilities for extensions of shared libraries, depending on whether the Fortran compiler or the system linker (usually the C compiler) has been used for linking. The default for the Fortran compiler on most systems is [[.so]]. <>= public :: os_data_t <>= type :: os_data_t logical :: use_libtool logical :: use_testfiles type(string_t) :: fc type(string_t) :: fcflags type(string_t) :: fcflags_pic type(string_t) :: fclibs type(string_t) :: fc_src_ext type(string_t) :: cc type(string_t) :: cflags type(string_t) :: cflags_pic type(string_t) :: cxx type(string_t) :: cxxflags type(string_t) :: cxxlibs type(string_t) :: obj_ext type(string_t) :: ld type(string_t) :: ldflags type(string_t) :: ldflags_so type(string_t) :: ldflags_static type(string_t) :: ldflags_hepmc type(string_t) :: ldflags_lcio type(string_t) :: ldflags_hoppet type(string_t) :: ldflags_looptools type(string_t) :: shrlib_ext type(string_t) :: fc_shrlib_ext type(string_t) :: pack_cmd type(string_t) :: unpack_cmd type(string_t) :: pack_ext type(string_t) :: makeflags type(string_t) :: prefix type(string_t) :: exec_prefix type(string_t) :: bindir type(string_t) :: libdir type(string_t) :: includedir type(string_t) :: datarootdir type(string_t) :: whizard_omega_binpath type(string_t) :: whizard_includes type(string_t) :: whizard_ldflags type(string_t) :: whizard_libtool type(string_t) :: whizard_modelpath type(string_t) :: whizard_modelpath_ufo type(string_t) :: whizard_models_libpath type(string_t) :: whizard_susypath type(string_t) :: whizard_gmlpath type(string_t) :: whizard_cutspath type(string_t) :: whizard_texpath type(string_t) :: whizard_sharepath type(string_t) :: whizard_testdatapath type(string_t) :: whizard_modelpath_local type(string_t) :: whizard_models_libpath_local type(string_t) :: whizard_omega_binpath_local type(string_t) :: whizard_circe2path type(string_t) :: whizard_beamsimpath type(string_t) :: whizard_mulipath type(string_t) :: pdf_builtin_datapath logical :: event_analysis = .false. logical :: event_analysis_ps = .false. logical :: event_analysis_pdf = .false. type(string_t) :: latex type(string_t) :: mpost type(string_t) :: gml type(string_t) :: dvips type(string_t) :: ps2pdf type(string_t) :: gosampath type(string_t) :: golempath type(string_t) :: formpath type(string_t) :: qgrafpath type(string_t) :: ninjapath type(string_t) :: samuraipath contains <> end type os_data_t @ %def os_data_t @ Since all are allocatable strings, explicit initialization is necessary. <>= integer, parameter, public :: ENVVAR_LEN = 1000 @ %def ENVVAR_LEN <>= procedure :: init => os_data_init <>= module subroutine os_data_init (os_data, paths) class(os_data_t), intent(out) :: os_data type(paths_t), intent(in), optional :: paths end subroutine os_data_init <>= module subroutine os_data_init (os_data, paths) class(os_data_t), intent(out) :: os_data type(paths_t), intent(in), optional :: paths character(len=ENVVAR_LEN) :: home type(string_t) :: localprefix, local_includes os_data%use_libtool = .true. inquire (file = "TESTFLAG", exist = os_data%use_testfiles) call get_environment_variable ("HOME", home) if (present(paths)) then if (paths%localprefix == "") then localprefix = trim (home) // "/.whizard" else localprefix = paths%localprefix end if else localprefix = trim (home) // "/.whizard" end if local_includes = localprefix // "/lib/whizard/mod/models" os_data%whizard_modelpath_local = localprefix // "/share/whizard/models" os_data%whizard_models_libpath_local = localprefix // "/lib/whizard/models" os_data%whizard_omega_binpath_local = localprefix // "/bin" os_data%fc = DEFAULT_FC os_data%fcflags = DEFAULT_FCFLAGS os_data%fcflags_pic = DEFAULT_FCFLAGS_PIC os_data%fclibs = FCLIBS os_data%fc_src_ext = DEFAULT_FC_SRC_EXT os_data%cc = DEFAULT_CC os_data%cflags = DEFAULT_CFLAGS os_data%cflags_pic = DEFAULT_CFLAGS_PIC os_data%cxx = DEFAULT_CXX os_data%cxxflags = DEFAULT_CXXFLAGS os_data%cxxlibs = DEFAULT_CXXLIBS os_data%obj_ext = DEFAULT_OBJ_EXT os_data%ld = DEFAULT_LD os_data%ldflags = DEFAULT_LDFLAGS os_data%ldflags_so = DEFAULT_LDFLAGS_SO os_data%ldflags_static = DEFAULT_LDFLAGS_STATIC os_data%ldflags_hepmc = DEFAULT_LDFLAGS_HEPMC os_data%ldflags_lcio = DEFAULT_LDFLAGS_LCIO os_data%ldflags_hoppet = DEFAULT_LDFLAGS_HOPPET os_data%ldflags_looptools = DEFAULT_LDFLAGS_LOOPTOOLS os_data%shrlib_ext = DEFAULT_SHRLIB_EXT os_data%fc_shrlib_ext = DEFAULT_FC_SHRLIB_EXT os_data%pack_cmd = DEFAULT_PACK_CMD os_data%unpack_cmd = DEFAULT_UNPACK_CMD os_data%pack_ext = DEFAULT_PACK_EXT os_data%makeflags = DEFAULT_MAKEFLAGS os_data%prefix = PREFIX os_data%exec_prefix = EXEC_PREFIX os_data%bindir = BINDIR os_data%libdir = LIBDIR os_data%includedir = INCLUDEDIR os_data%datarootdir = DATAROOTDIR if (present (paths)) then if (paths%prefix /= "") os_data%prefix = paths%prefix if (paths%exec_prefix /= "") os_data%exec_prefix = paths%exec_prefix if (paths%bindir /= "") os_data%bindir = paths%bindir if (paths%libdir /= "") os_data%libdir = paths%libdir if (paths%includedir /= "") os_data%includedir = paths%includedir if (paths%datarootdir /= "") os_data%datarootdir = paths%datarootdir end if if (os_data%use_testfiles) then os_data%whizard_omega_binpath = WHIZARD_TEST_OMEGA_BINPATH os_data%whizard_includes = WHIZARD_TEST_INCLUDES os_data%whizard_ldflags = WHIZARD_TEST_LDFLAGS os_data%whizard_libtool = WHIZARD_LIBTOOL_TEST os_data%whizard_modelpath = WHIZARD_TEST_MODELPATH os_data%whizard_modelpath_ufo = WHIZARD_TEST_MODELPATH_UFO os_data%whizard_models_libpath = WHIZARD_TEST_MODELS_LIBPATH os_data%whizard_susypath = WHIZARD_TEST_SUSYPATH os_data%whizard_gmlpath = WHIZARD_TEST_GMLPATH os_data%whizard_cutspath = WHIZARD_TEST_CUTSPATH os_data%whizard_texpath = WHIZARD_TEST_TEXPATH os_data%whizard_sharepath = WHIZARD_TEST_SHAREPATH os_data%whizard_testdatapath = WHIZARD_TEST_TESTDATAPATH os_data%whizard_circe2path = WHIZARD_TEST_CIRCE2PATH os_data%whizard_beamsimpath = WHIZARD_TEST_BEAMSIMPATH os_data%whizard_mulipath = WHIZARD_TEST_MULIPATH os_data%pdf_builtin_datapath = PDF_BUILTIN_TEST_DATAPATH else if (os_dir_exist (local_includes)) then os_data%whizard_includes = "-I" // local_includes // " "// & WHIZARD_INCLUDES else os_data%whizard_includes = WHIZARD_INCLUDES end if os_data%whizard_omega_binpath = WHIZARD_OMEGA_BINPATH os_data%whizard_ldflags = WHIZARD_LDFLAGS os_data%whizard_libtool = WHIZARD_LIBTOOL if(present(paths)) then if (paths%libtool /= "") os_data%whizard_libtool = paths%libtool end if os_data%whizard_modelpath = WHIZARD_MODELPATH os_data%whizard_modelpath_ufo = WHIZARD_MODELPATH_UFO os_data%whizard_models_libpath = WHIZARD_MODELS_LIBPATH os_data%whizard_susypath = WHIZARD_SUSYPATH os_data%whizard_gmlpath = WHIZARD_GMLPATH os_data%whizard_cutspath = WHIZARD_CUTSPATH os_data%whizard_texpath = WHIZARD_TEXPATH os_data%whizard_sharepath = WHIZARD_SHAREPATH os_data%whizard_testdatapath = WHIZARD_TESTDATAPATH os_data%whizard_circe2path = WHIZARD_CIRCE2PATH os_data%whizard_beamsimpath = WHIZARD_BEAMSIMPATH os_data%whizard_mulipath = WHIZARD_MULIPATH os_data%pdf_builtin_datapath = PDF_BUILTIN_DATAPATH end if os_data%event_analysis = EVENT_ANALYSIS == "yes" os_data%event_analysis_ps = EVENT_ANALYSIS_PS == "yes" os_data%event_analysis_pdf = EVENT_ANALYSIS_PDF == "yes" os_data%latex = PRG_LATEX // " " // OPT_LATEX os_data%mpost = PRG_MPOST // " " // OPT_MPOST if (os_data%use_testfiles) then os_data%gml = os_data%whizard_gmlpath // "/whizard-gml" // " " // & OPT_MPOST // " " // "--gmldir " // os_data%whizard_gmlpath else os_data%gml = os_data%bindir // "/whizard-gml" // " " // OPT_MPOST & // " " // "--gmldir " // os_data%whizard_gmlpath end if os_data%dvips = PRG_DVIPS os_data%ps2pdf = PRG_PS2PDF call os_data_expand_paths (os_data) os_data%gosampath = GOSAM_DIR os_data%golempath = GOLEM_DIR os_data%formpath = FORM_DIR os_data%qgrafpath = QGRAF_DIR os_data%ninjapath = NINJA_DIR os_data%samuraipath = SAMURAI_DIR end subroutine os_data_init @ %def os_data_init @ Replace occurences of GNU path variables (such as [[${prefix}]]) by their values. Do this for all strings that could depend on them, and do the replacement in reverse order, since the path variables may be defined in terms of each other. %% Fooling Noweb Emacs mode: $ <>= subroutine os_data_expand_paths (os_data) type(os_data_t), intent(inout) :: os_data integer, parameter :: N_VARIABLES = 6 type(string_t), dimension(N_VARIABLES) :: variable, value variable(1) = "${prefix}"; value(1) = os_data%prefix variable(2) = "${exec_prefix}"; value(2) = os_data%exec_prefix variable(3) = "${bindir}"; value(3) = os_data%bindir variable(4) = "${libdir}"; value(4) = os_data%libdir variable(5) = "${includedir}"; value(5) = os_data%includedir variable(6) = "${datarootdir}"; value(6) = os_data%datarootdir call expand_paths (os_data%whizard_omega_binpath) call expand_paths (os_data%whizard_includes) call expand_paths (os_data%whizard_ldflags) call expand_paths (os_data%whizard_libtool) call expand_paths (os_data%whizard_modelpath) call expand_paths (os_data%whizard_modelpath_ufo) call expand_paths (os_data%whizard_models_libpath) call expand_paths (os_data%whizard_susypath) call expand_paths (os_data%whizard_gmlpath) call expand_paths (os_data%whizard_cutspath) call expand_paths (os_data%whizard_texpath) call expand_paths (os_data%whizard_sharepath) call expand_paths (os_data%whizard_testdatapath) call expand_paths (os_data%whizard_circe2path) call expand_paths (os_data%whizard_beamsimpath) call expand_paths (os_data%whizard_mulipath) call expand_paths (os_data%whizard_models_libpath_local) call expand_paths (os_data%whizard_modelpath_local) call expand_paths (os_data%whizard_omega_binpath_local) call expand_paths (os_data%pdf_builtin_datapath) call expand_paths (os_data%latex) call expand_paths (os_data%mpost) call expand_paths (os_data%gml) call expand_paths (os_data%dvips) call expand_paths (os_data%ps2pdf) contains subroutine expand_paths (string) type(string_t), intent(inout) :: string integer :: i do i = N_VARIABLES, 1, -1 string = replace (string, variable(i), value(i), every=.true.) end do end subroutine expand_paths end subroutine os_data_expand_paths @ %def os_data_update_paths @ Write contents <>= procedure :: write => os_data_write <>= module subroutine os_data_write (os_data, unit) class(os_data_t), intent(in) :: os_data integer, intent(in), optional :: unit end subroutine os_data_write <>= module subroutine os_data_write (os_data, unit) class(os_data_t), intent(in) :: os_data integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "OS data:" write (u, *) "use_libtool = ", os_data%use_libtool write (u, *) "use_testfiles = ", os_data%use_testfiles write (u, *) "fc = ", char (os_data%fc) write (u, *) "fcflags = ", char (os_data%fcflags) write (u, *) "fcflags_pic = ", char (os_data%fcflags_pic) write (u, *) "fclibs = ", char (os_data%fclibs) write (u, *) "fc_src_ext = ", char (os_data%fc_src_ext) write (u, *) "cc = ", char (os_data%cc) write (u, *) "cflags = ", char (os_data%cflags) write (u, *) "cflags_pic = ", char (os_data%cflags_pic) write (u, *) "cxx = ", char (os_data%cxx) write (u, *) "cxxflags = ", char (os_data%cxxflags) write (u, *) "cxxlibs = ", char (os_data%cxxlibs) write (u, *) "obj_ext = ", char (os_data%obj_ext) write (u, *) "ld = ", char (os_data%ld) write (u, *) "ldflags = ", char (os_data%ldflags) write (u, *) "ldflags_so = ", char (os_data%ldflags_so) write (u, *) "ldflags_static = ", char (os_data%ldflags_static) write (u, *) "ldflags_hepmc = ", char (os_data%ldflags_hepmc) write (u, *) "ldflags_lcio = ", char (os_data%ldflags_lcio) write (u, *) "ldflags_hoppet = ", char (os_data%ldflags_hoppet) write (u, *) "ldflags_looptools = ", char (os_data%ldflags_looptools) write (u, *) "shrlib_ext = ", char (os_data%shrlib_ext) write (u, *) "fc_shrlib_ext = ", char (os_data%fc_shrlib_ext) write (u, *) "makeflags = ", char (os_data%makeflags) write (u, *) "prefix = ", char (os_data%prefix) write (u, *) "exec_prefix = ", char (os_data%exec_prefix) write (u, *) "bindir = ", char (os_data%bindir) write (u, *) "libdir = ", char (os_data%libdir) write (u, *) "includedir = ", char (os_data%includedir) write (u, *) "datarootdir = ", char (os_data%datarootdir) write (u, *) "whizard_omega_binpath = ", & char (os_data%whizard_omega_binpath) write (u, *) "whizard_includes = ", char (os_data%whizard_includes) write (u, *) "whizard_ldflags = ", char (os_data%whizard_ldflags) write (u, *) "whizard_libtool = ", char (os_data%whizard_libtool) write (u, *) "whizard_modelpath = ", & char (os_data%whizard_modelpath) write (u, *) "whizard_modelpath_ufo = ", & char (os_data%whizard_modelpath_ufo) write (u, *) "whizard_models_libpath = ", & char (os_data%whizard_models_libpath) write (u, *) "whizard_susypath = ", char (os_data%whizard_susypath) write (u, *) "whizard_gmlpath = ", char (os_data%whizard_gmlpath) write (u, *) "whizard_cutspath = ", char (os_data%whizard_cutspath) write (u, *) "whizard_texpath = ", char (os_data%whizard_texpath) write (u, *) "whizard_circe2path = ", char (os_data%whizard_circe2path) write (u, *) "whizard_beamsimpath = ", char (os_data%whizard_beamsimpath) write (u, *) "whizard_mulipath = ", char (os_data%whizard_mulipath) write (u, *) "whizard_sharepath = ", & char (os_data%whizard_sharepath) write (u, *) "whizard_testdatapath = ", & char (os_data%whizard_testdatapath) write (u, *) "whizard_modelpath_local = ", & char (os_data%whizard_modelpath_local) write (u, *) "whizard_models_libpath_local = ", & char (os_data%whizard_models_libpath_local) write (u, *) "whizard_omega_binpath_local = ", & char (os_data%whizard_omega_binpath_local) write (u, *) "event_analysis = ", os_data%event_analysis write (u, *) "event_analysis_ps = ", os_data%event_analysis_ps write (u, *) "event_analysis_pdf = ", os_data%event_analysis_pdf write (u, *) "latex = ", char (os_data%latex) write (u, *) "mpost = ", char (os_data%mpost) write (u, *) "gml = ", char (os_data%gml) write (u, *) "dvips = ", char (os_data%dvips) write (u, *) "ps2pdf = ", char (os_data%ps2pdf) if (os_data%gosampath /= "") then write (u, *) "gosam = ", char (os_data%gosampath) write (u, *) "golem = ", char (os_data%golempath) write (u, *) "form = ", char (os_data%formpath) write (u, *) "qgraf = ", char (os_data%qgrafpath) write (u, *) "ninja = ", char (os_data%ninjapath) write (u, *) "samurai = ", char (os_data%samuraipath) end if end subroutine os_data_write @ %def os_data_write @ <>= procedure :: build_latex_file => os_data_build_latex_file <>= module subroutine os_data_build_latex_file (os_data, filename, stat_out) class(os_data_t), intent(in) :: os_data type(string_t), intent(in) :: filename integer, intent(out), optional :: stat_out end subroutine os_data_build_latex_file <>= module subroutine os_data_build_latex_file (os_data, filename, stat_out) class(os_data_t), intent(in) :: os_data type(string_t), intent(in) :: filename integer, intent(out), optional :: stat_out type(string_t) :: setenv_tex, pipe, pipe_dvi integer :: unit_dev, status status = -1 if (os_data%event_analysis_ps) then !!! Check if our OS has a /dev/null unit_dev = free_unit () open (file = "/dev/null", unit = unit_dev, & action = "write", iostat = status) close (unit_dev) if (status /= 0) then pipe = "" pipe_dvi = "" else pipe = " > /dev/null" pipe_dvi = " 2>/dev/null 1>/dev/null" end if if (os_data%whizard_texpath /= "") then setenv_tex = "TEXINPUTS=" // & os_data%whizard_texpath // ":$TEXINPUTS " else setenv_tex = "" end if call os_system_call (setenv_tex // & os_data%latex // " " // filename // ".tex " // pipe, & verbose = .true., status = status) call os_system_call (os_data%dvips // " -o " // filename // & ".ps " // filename // ".dvi" // pipe_dvi, verbose = .true., & status = status) call os_system_call (os_data%ps2pdf // " " // filename // ".ps", & verbose = .true., status = status) end if if (present (stat_out)) stat_out = status end subroutine os_data_build_latex_file @ %def os_data_build_latex_file @ \subsection{Dynamic linking} We define a type that holds the filehandle for a dynamically linked library (shared object), together with functions to open and close the library, and to access functions in this library. <>= public :: dlaccess_t <>= type :: dlaccess_t private type(string_t) :: filename type(c_ptr) :: handle = c_null_ptr logical :: is_open = .false. logical :: has_error = .false. type(string_t) :: error contains <> end type dlaccess_t @ %def dlaccess_t @ Output. This is called by the output routine for the process library. <>= procedure :: write => dlaccess_write <>= module subroutine dlaccess_write (object, unit) class(dlaccess_t), intent(in) :: object integer, intent(in) :: unit end subroutine dlaccess_write <>= module subroutine dlaccess_write (object, unit) class(dlaccess_t), intent(in) :: object integer, intent(in) :: unit write (unit, "(1x,A)") "DL access info:" write (unit, "(3x,A,L1)") "is open = ", object%is_open if (object%has_error) then write (unit, "(3x,A,A,A)") "error = '", char (object%error), "'" else write (unit, "(3x,A)") "error = [none]" end if end subroutine dlaccess_write @ %def dlaccess_write @ The interface to the library functions: <>= interface function dlopen (filename, flag) result (handle) bind(C) import character(c_char), dimension(*) :: filename integer(c_int), value :: flag type(c_ptr) :: handle end function dlopen end interface interface function dlclose (handle) result (status) bind(C) import type(c_ptr), value :: handle integer(c_int) :: status end function dlclose end interface interface function dlerror () result (str) bind(C) import type(c_ptr) :: str end function dlerror end interface interface function dlsym (handle, symbol) result (fptr) bind(C) import type(c_ptr), value :: handle character(c_char), dimension(*) :: symbol type(c_funptr) :: fptr end function dlsym end interface @ %def dlopen dlclose dlsym @ This reads an error string and transforms it into a [[string_t]] object, if an error has occured. If not, set the error flag to false and return an empty string. <>= integer, parameter, public :: DLERROR_LEN = 160 <>= subroutine read_dlerror (has_error, error) logical, intent(out) :: has_error type(string_t), intent(out) :: error type(c_ptr) :: err_cptr character(len=DLERROR_LEN, kind=c_char), pointer :: err_fptr integer :: str_end err_cptr = dlerror () if (c_associated (err_cptr)) then call c_f_pointer (err_cptr, err_fptr) has_error = .true. str_end = scan (err_fptr, c_null_char) if (str_end > 0) then error = err_fptr(1:str_end-1) else error = err_fptr end if else has_error = .false. error = "" end if end subroutine read_dlerror @ %def read_dlerror @ This is the Fortran API. Init/final open and close the file, i.e., load and unload the library. Note that a library can be opened more than once, and that for an ultimate close as many [[dlclose]] calls as [[dlopen]] calls are necessary. However, we assume that it is opened and closed only once. <>= public :: dlaccess_init public :: dlaccess_final <>= procedure :: init => dlaccess_init procedure :: final => dlaccess_final <>= module subroutine dlaccess_init (dlaccess, prefix, libname, os_data) class(dlaccess_t), intent(out) :: dlaccess type(string_t), intent(in) :: prefix, libname type(os_data_t), intent(in), optional :: os_data end subroutine dlaccess_init module subroutine dlaccess_final (dlaccess) class(dlaccess_t), intent(inout) :: dlaccess end subroutine dlaccess_final <>= module subroutine dlaccess_init (dlaccess, prefix, libname, os_data) class(dlaccess_t), intent(out) :: dlaccess type(string_t), intent(in) :: prefix, libname type(os_data_t), intent(in), optional :: os_data type(string_t) :: filename logical :: exist dlaccess%filename = libname filename = prefix // "/" // libname inquire (file=char(filename), exist=exist) if (.not. exist) then filename = prefix // "/.libs/" // libname inquire (file=char(filename), exist=exist) if (.not. exist) then dlaccess%has_error = .true. dlaccess%error = "Library '" // filename // "' not found" return end if end if dlaccess%handle = dlopen (char (filename) // c_null_char, ior ( & RTLD_LAZY, RTLD_LOCAL)) dlaccess%is_open = c_associated (dlaccess%handle) call read_dlerror (dlaccess%has_error, dlaccess%error) end subroutine dlaccess_init module subroutine dlaccess_final (dlaccess) class(dlaccess_t), intent(inout) :: dlaccess integer(c_int) :: status if (dlaccess%is_open) then status = dlclose (dlaccess%handle) dlaccess%is_open = .false. call read_dlerror (dlaccess%has_error, dlaccess%error) end if end subroutine dlaccess_final @ %def dlaccess_init dlaccess_final @ Return true if an error has occured. <>= public :: dlaccess_has_error <>= module function dlaccess_has_error (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess end function dlaccess_has_error <>= module function dlaccess_has_error (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess flag = dlaccess%has_error end function dlaccess_has_error @ %def dlaccess_has_error @ Return the error string currently stored in the [[dlaccess]] object. <>= public :: dlaccess_get_error <>= module function dlaccess_get_error (dlaccess) result (error) type(string_t) :: error type(dlaccess_t), intent(in) :: dlaccess end function dlaccess_get_error <>= module function dlaccess_get_error (dlaccess) result (error) type(string_t) :: error type(dlaccess_t), intent(in) :: dlaccess error = dlaccess%error end function dlaccess_get_error @ %def dlaccess_get_error @ The symbol handler returns the C address of the function with the given string name. (It is a good idea to use [[bind(C)]] for all functions accessed by this, such that the name string is well-defined.) Call [[c_f_procpointer]] to cast this into a Fortran procedure pointer with an appropriate interface. <>= public :: dlaccess_get_c_funptr <>= module function dlaccess_get_c_funptr (dlaccess, fname) result (fptr) type(c_funptr) :: fptr type(dlaccess_t), intent(inout) :: dlaccess type(string_t), intent(in) :: fname end function dlaccess_get_c_funptr <>= module function dlaccess_get_c_funptr (dlaccess, fname) result (fptr) type(c_funptr) :: fptr type(dlaccess_t), intent(inout) :: dlaccess type(string_t), intent(in) :: fname fptr = dlsym (dlaccess%handle, char (fname) // c_null_char) call read_dlerror (dlaccess%has_error, dlaccess%error) end function dlaccess_get_c_funptr @ %def dlaccess_get_c_funptr @ \subsection{Predicates} Return true if the library is loaded. In particular, this is false if loading was unsuccessful. <>= public :: dlaccess_is_open <>= module function dlaccess_is_open (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess end function dlaccess_is_open <>= module function dlaccess_is_open (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess flag = dlaccess%is_open end function dlaccess_is_open @ %def dlaccess_is_open @ \subsection{Shell access} This is the standard system call for executing a shell command, such as invoking a compiler. In F2008 there will be the equivalent built-in command [[execute_command_line]]. <>= public :: os_system_call <>= module subroutine os_system_call (command_string, status, verbose) type(string_t), intent(in) :: command_string integer, intent(out), optional :: status logical, intent(in), optional :: verbose end subroutine os_system_call <>= module subroutine os_system_call (command_string, status, verbose) type(string_t), intent(in) :: command_string integer, intent(out), optional :: status logical, intent(in), optional :: verbose logical :: verb integer :: stat verb = .false.; if (present (verbose)) verb = verbose if (verb) & call msg_message ("command: " // char (command_string)) stat = system (char (command_string) // c_null_char) if (present (status)) then status = stat else if (stat /= 0) then if (.not. verb) & call msg_message ("command: " // char (command_string)) write (msg_buffer, "(A,I0)") "Return code = ", stat call msg_message () call msg_fatal ("System command returned with nonzero status code") end if end subroutine os_system_call @ %def os_system_call <>= interface function system (command) result (status) bind(C) import integer(c_int) :: status character(c_char), dimension(*) :: command end function system end interface @ %def system @ \subsection{Querying for a directory} This queries for the existence of a directory. There is no standard way to achieve this in FORTRAN, and if we were to call into [[libc]], we would need access to C macros for evaluating the result, so we resort to calling [[test]] as a system call. <>= public :: os_dir_exist <>= module function os_dir_exist (name) result (res) type(string_t), intent(in) :: name logical :: res end function os_dir_exist <>= module function os_dir_exist (name) result (res) type(string_t), intent(in) :: name logical :: res integer :: status call os_system_call ('test -d "' // name // '"', status=status) res = status == 0 end function os_dir_exist @ %def os_dir_exist @ <>= public :: os_file_exist <>= module function os_file_exist (name) result (exist) type(string_t), intent(in) :: name logical :: exist end function os_file_exist <>= module function os_file_exist (name) result (exist) type(string_t), intent(in) :: name logical :: exist inquire (file = char (name), exist=exist) end function os_file_exist @ %def os_file_exist @ \subsection{Pack/unpack} The argument to [[pack]] may be a file or a directory. The name of the packed file will get the [[pack_ext]] extension appended. The argument to [[unpack]] must be a file, with the extension already included in the file name. <>= public :: os_pack_file public :: os_unpack_file <>= module subroutine os_pack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_pack_file module subroutine os_unpack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_unpack_file <>= module subroutine os_pack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string command_string = os_data%pack_cmd // " " & // file // os_data%pack_ext // " " // file call os_system_call (command_string, status) end subroutine os_pack_file module subroutine os_unpack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string command_string = os_data%unpack_cmd // " " // file call os_system_call (command_string, status) end subroutine os_unpack_file @ %def os_pack_file @ %def os_unpack_file @ \subsection{Fortran compiler and linker} Compile a single module for use in a shared library, but without linking. <>= public :: os_compile_shared <>= module subroutine os_compile_shared (src, os_data, status) type(string_t), intent(in) :: src type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_compile_shared <>= module subroutine os_compile_shared (src, os_data, status) type(string_t), intent(in) :: src type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=compile " // & os_data%fc // " " // & "-c " // & os_data%whizard_includes // " " // & os_data%fcflags // " " // & "'" // src // os_data%fc_src_ext // "'" else command_string = & os_data%fc // " " // & "-c " // & os_data%fcflags_pic // " " // & os_data%whizard_includes // " " // & os_data%fcflags // " " // & "'" // src // os_data%fc_src_ext // "'" end if call os_system_call (command_string, status) end subroutine os_compile_shared @ %def os_compile_shared @ Link an array of object files to build a shared object library. In the libtool case, we have to specify a [[-rpath]], otherwise only a static library can be built. However, since the library is never installed, this rpath is irrelevant. <>= public :: os_link_shared <>= module subroutine os_link_shared (objlist, lib, os_data, status) type(string_t), intent(in) :: objlist, lib type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_link_shared <>= module subroutine os_link_shared (objlist, lib, os_data, status) type(string_t), intent(in) :: objlist, lib type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=link " // & os_data%fc // " " // & "-module " // & "-rpath /usr/local/lib" // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & "-o '" // lib // ".la' " // & objlist else command_string = & os_data%ld // " " // & os_data%ldflags_so // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & "-o '" // lib // "." // os_data%fc_shrlib_ext // "' " // & objlist end if call os_system_call (command_string, status) end subroutine os_link_shared @ %def os_link_shared @ Link an array of object files / libraries to build a static executable. <>= public :: os_link_static <>= module subroutine os_link_static (objlist, exec_name, os_data, status) type(string_t), intent(in) :: objlist, exec_name type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_link_static <>= module subroutine os_link_static (objlist, exec_name, os_data, status) type(string_t), intent(in) :: objlist, exec_name type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=link " // & os_data%fc // " " // & "-static " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & os_data%ldflags_static // " " // & "-o '" // exec_name // "' " // & objlist // " " // & os_data%ldflags_hepmc // " " // & os_data%ldflags_lcio // " " // & os_data%ldflags_hoppet // " " // & os_data%ldflags_looptools else command_string = & os_data%ld // " " // & os_data%ldflags_so // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & os_data%ldflags_static // " " // & "-o '" // exec_name // "' " // & objlist // " " // & os_data%ldflags_hepmc // " " // & os_data%ldflags_lcio // " " // & os_data%ldflags_hoppet // " " // & os_data%ldflags_looptools end if call os_system_call (command_string, status) end subroutine os_link_static @ %def os_link_static @ Determine the name of the shared library to link. If libtool is used, this is encoded in the [[.la]] file which resides in place of the library itself. <>= public :: os_get_dlname <>= module function os_get_dlname (lib, os_data, ignore, silent) result (dlname) type(string_t) :: dlname type(string_t), intent(in) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: ignore, silent end function os_get_dlname <>= module function os_get_dlname (lib, os_data, ignore, silent) result (dlname) type(string_t) :: dlname type(string_t), intent(in) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: ignore, silent type(string_t) :: filename type(string_t) :: buffer logical :: exist, required, quiet integer :: u u = free_unit () if (present (ignore)) then required = .not. ignore else required = .true. end if if (present (silent)) then quiet = silent else quiet = .false. end if if (os_data%use_libtool) then filename = lib // ".la" inquire (file=char(filename), exist=exist) if (exist) then open (unit=u, file=char(filename), action="read", status="old") SCAN_LTFILE: do call get (u, buffer) if (extract (buffer, 1, 7) == "dlname=") then dlname = extract (buffer, 9) dlname = remove (dlname, len (dlname)) exit SCAN_LTFILE end if end do SCAN_LTFILE close (u) else if (required) then if (.not. quiet) call msg_fatal (" Library '" // char (lib) & // "': libtool archive not found") dlname = "" else if (.not. quiet) call msg_message ("[No compiled library '" & // char (lib) // "']") dlname = "" end if else dlname = lib // "." // os_data%fc_shrlib_ext inquire (file=char(dlname), exist=exist) if (.not. exist) then if (required) then if (.not. quiet) call msg_fatal (" Library '" // char (lib) & // "' not found") else if (.not. quiet) call msg_message & ("[No compiled process library '" // char (lib) // "']") dlname = "" end if end if end if end function os_get_dlname @ %def os_get_dlname @ \subsection{Controlling OpenMP} OpenMP is handled automatically by the library for the most part. Here is a convenience routine for setting the number of threads, with some diagnostics. <>= public :: openmp_set_num_threads_verbose <>= module subroutine openmp_set_num_threads_verbose (num_threads, openmp_logging) integer, intent(in) :: num_threads logical, intent(in), optional :: openmp_logging end subroutine openmp_set_num_threads_verbose <>= module subroutine openmp_set_num_threads_verbose (num_threads, openmp_logging) integer, intent(in) :: num_threads integer :: n_threads logical, intent(in), optional :: openmp_logging logical :: logging if (present (openmp_logging)) then logging = openmp_logging else logging = .true. end if n_threads = num_threads if (openmp_is_active ()) then if (num_threads == 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", num_threads, & " thread" call msg_message end if n_threads = num_threads else if (num_threads > 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", num_threads, & " threads" call msg_message end if n_threads = num_threads else if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: " & // "Illegal value of openmp_num_threads (", num_threads, & ") ignored" call msg_error end if n_threads = openmp_get_default_max_threads () if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", & n_threads, " threads" call msg_message end if end if if (n_threads > openmp_get_default_max_threads ()) then if (logging) then write (msg_buffer, "(A,I0)") "OpenMP: " & // "Number of threads is greater than library default of ", & openmp_get_default_max_threads () call msg_warning end if end if call openmp_set_num_threads (n_threads) else if (num_threads /= 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "openmp_num_threads set to ", & num_threads, ", but OpenMP is not active: ignored" call msg_warning end if end if end subroutine openmp_set_num_threads_verbose @ %def openmp_set_num_threads_verbose @ \subsection{Controlling MPI} The overall MPI handling has to be defined in a context specific way, but we can simplify things like logging or receiving [[n_size]] or [[rank]]. <>= public :: mpi_set_logging <>= module subroutine mpi_set_logging (mpi_logging) logical, intent(in) :: mpi_logging end subroutine mpi_set_logging <>= module subroutine mpi_set_logging (mpi_logging) logical, intent(in) :: mpi_logging integer :: n_size, rank call mpi_get_comm_id (n_size, rank) if (mpi_logging .and. n_size > 1) then write (msg_buffer, "(A,I0,A)") "MPI: Using ", n_size, " processes." call msg_message () if (rank == 0) then call msg_message ("MPI: master worker") else write (msg_buffer, "(A,I0)") "MPI: slave worker #", rank call msg_message () end if end if end subroutine mpi_set_logging @ %def mpi_set_logging @ Receive communicator size and rank inside communicator. The subroutine is a stub, if not compiled with [[MPI]]. <>= public :: mpi_get_comm_id <>= module subroutine mpi_get_comm_id (n_size, rank) integer, intent(out) :: n_size integer, intent(out) :: rank end subroutine mpi_get_comm_id <>= module subroutine mpi_get_comm_id (n_size, rank) integer, intent(out) :: n_size integer, intent(out) :: rank n_size = 1 rank = 0 <> end subroutine mpi_get_comm_id @ %def mpi_get_comm_id <>= @ <>= call MPI_Comm_size (MPI_COMM_WORLD, n_size) call MPI_Comm_rank (MPI_COMM_WORLD, rank) @ <>= public :: mpi_is_comm_master <>= module function mpi_is_comm_master () result (flag) logical :: flag end function mpi_is_comm_master <>= module function mpi_is_comm_master () result (flag) integer :: n_size, rank logical :: flag call mpi_get_comm_id (n_size, rank) flag = (rank == 0) end function mpi_is_comm_master @ %def mpi_is_comm_master @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[os_interface_ut.f90]]>>= <> module os_interface_ut use unit_tests use os_interface_uti <> <> contains <> end module os_interface_ut @ %def os_interface_ut @ <<[[os_interface_uti.f90]]>>= <> module os_interface_uti use, intrinsic :: iso_c_binding !NODEP! <> use io_units use os_interface <> <> contains <> end module os_interface_uti @ %def os_interface_ut @ API: driver for the unit tests below. <>= public :: os_interface_test <>= subroutine os_interface_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine os_interface_test @ %def os_interface_test @ Write a Fortran source file, compile it to a shared library, load it, and execute the contained function. <>= call test (os_interface_1, "os_interface_1", & "check OS interface routines", & u, results) <>= public :: os_interface_1 <>= subroutine os_interface_1 (u) integer, intent(in) :: u type(dlaccess_t) :: dlaccess type(string_t) :: fname, libname, ext type(os_data_t) :: os_data type(string_t) :: filename_src, filename_obj abstract interface function so_test_proc (i) result (j) bind(C) import c_int integer(c_int), intent(in) :: i integer(c_int) :: j end function so_test_proc end interface procedure(so_test_proc), pointer :: so_test => null () type(c_funptr) :: c_fptr integer :: unit integer(c_int) :: i call os_data%init () fname = "so_test" filename_src = fname // os_data%fc_src_ext if (os_data%use_libtool) then ext = ".lo" else ext = os_data%obj_ext end if filename_obj = fname // ext libname = fname // '.' // os_data%fc_shrlib_ext write (u, "(A)") "* Test output: OS interface" write (u, "(A)") "* Purpose: check os_interface routines" write (u, "(A)") write (u, "(A)") "* write source file 'so_test.f90'" write (u, "(A)") unit = free_unit () open (unit=unit, file=char(filename_src), action="write") write (unit, "(A)") "function so_test (i) result (j) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " integer(c_int) :: j" write (unit, "(A)") " j = 2 * i" write (unit, "(A)") "end function so_test" close (unit) write (u, "(A)") "* compile and link as 'so_test.so/dylib'" write (u, "(A)") call os_compile_shared (fname, os_data) call os_link_shared (filename_obj, fname, os_data) write (u, "(A)") "* load library 'so_test.so/dylib'" write (u, "(A)") call dlaccess_init (dlaccess, var_str ("."), libname, os_data) if (dlaccess_is_open (dlaccess)) then write (u, "(A)") " success" else write (u, "(A)") " failure" end if write (u, "(A)") "* load symbol 'so_test'" write (u, "(A)") c_fptr = dlaccess_get_c_funptr (dlaccess, fname) if (c_associated (c_fptr)) then write (u, "(A)") " success" else write (u, "(A)") " failure" end if call c_f_procpointer (c_fptr, so_test) write (u, "(A)") "* Execute function from 'so_test.so/dylib'" i = 7 write (u, "(A,1x,I1)") " input = ", i write (u, "(A,1x,I1)") " result = ", so_test(i) if (so_test(i) / i .ne. 2) then write (u, "(A)") "* Compiling and linking ISO C functions failed." else write (u, "(A)") "* Successful." end if write (u, "(A)") write (u, "(A)") "* Cleanup" call dlaccess_final (dlaccess) end subroutine os_interface_1 @ %def os_interface_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Interface for formatted I/O} For access to formatted printing (possibly input), we interface the C [[printf]] family of functions. There are two important issues here: \begin{enumerate} \item [[printf]] takes an arbitrary number of arguments, relying on the C stack. This is not interoperable. We interface it with C wrappers that output a single integer, real or string and restrict the allowed formats accordingly. \item Restricting format strings is essential also for preventing format string attacks. Allowing arbitrary format string would create a real security hole in a Fortran program. \item The string returned by [[sprintf]] must be allocated to the right size. \end{enumerate} <<[[formats.f90]]>>= <> module formats use, intrinsic :: iso_c_binding <> <> <> <> <> <> <> interface <> end interface end module formats @ %def formats @ <<[[formats_sub.f90]]>>= <> submodule (formats) formats_s use io_units use diagnostics implicit none contains <> end submodule formats_s @ %def formats_s @ \subsection{Parsing a C format string} The C format string contains characters and format conversion specifications. The latter are initiated by a [[%]] sign. If the next letter is also a [[%]], a percent sign is printed and no conversion is done. Otherwise, a conversion is done and applied to the next argument in the argument list. First comes an optional flag ([[#]], [[0]], [[-]], [[+]], or space), an optional field width (decimal digits starting not with zero), an optional precision (period, then another decimal digit string), a length modifier (irrelevant for us, therefore not supported), and a conversion specifier: [[d]] or [[i]] for integer; [[e]], [[f]], [[g]] (also upper case) for double-precision real, [[s]] for a string. We explicitly exclude all other conversion specifiers, and we check the specifiers against the actual arguments. \subsubsection{A type for passing arguments} This is a polymorphic type that can hold integer, real (double), and string arguments. <>= integer, parameter, public :: ARGTYPE_NONE = 0 integer, parameter, public :: ARGTYPE_LOG = 1 integer, parameter, public :: ARGTYPE_INT = 2 integer, parameter, public :: ARGTYPE_REAL = 3 integer, parameter, public :: ARGTYPE_STR = 4 @ %def ARGTYPE_NONE ARGTYPE_LOG ARGTYPE_INT ARGTYPE_REAL ARGTYPE_STRING @ The integer and real entries are actually scalars, but we avoid relying on the allocatable-scalar feature and make them one-entry arrays. The character entry is a real array which is a copy of the string. Logical values are mapped to strings (true or false), so this type parameter value is mostly unused. <>= public :: sprintf_arg_t <>= type :: sprintf_arg_t private integer :: type = ARGTYPE_NONE integer(c_int), dimension(:), allocatable :: ival real(c_double), dimension(:), allocatable :: rval character(c_char), dimension(:), allocatable :: sval end type sprintf_arg_t @ %def sprintf_arg_t <>= public :: sprintf_arg_init <>= interface sprintf_arg_init module procedure sprintf_arg_init_log module procedure sprintf_arg_init_int module procedure sprintf_arg_init_real module procedure sprintf_arg_init_str end interface <>= module subroutine sprintf_arg_init_log (arg, lval) type(sprintf_arg_t), intent(out) :: arg logical, intent(in) :: lval end subroutine sprintf_arg_init_log module subroutine sprintf_arg_init_int (arg, ival) type(sprintf_arg_t), intent(out) :: arg integer, intent(in) :: ival end subroutine sprintf_arg_init_int module subroutine sprintf_arg_init_real (arg, rval) type(sprintf_arg_t), intent(out) :: arg real(default), intent(in) :: rval end subroutine sprintf_arg_init_real module subroutine sprintf_arg_init_str (arg, sval) type(sprintf_arg_t), intent(out) :: arg type(string_t), intent(in) :: sval end subroutine sprintf_arg_init_str <>= module subroutine sprintf_arg_init_log (arg, lval) type(sprintf_arg_t), intent(out) :: arg logical, intent(in) :: lval arg%type = ARGTYPE_STR if (lval) then allocate (arg%sval (5)) arg%sval = ['t', 'r', 'u', 'e', c_null_char] else allocate (arg%sval (6)) arg%sval = ['f', 'a', 'l', 's', 'e', c_null_char] end if end subroutine sprintf_arg_init_log module subroutine sprintf_arg_init_int (arg, ival) type(sprintf_arg_t), intent(out) :: arg integer, intent(in) :: ival arg%type = ARGTYPE_INT allocate (arg%ival (1)) arg%ival = ival end subroutine sprintf_arg_init_int module subroutine sprintf_arg_init_real (arg, rval) type(sprintf_arg_t), intent(out) :: arg real(default), intent(in) :: rval arg%type = ARGTYPE_REAL allocate (arg%rval (1)) arg%rval = rval end subroutine sprintf_arg_init_real module subroutine sprintf_arg_init_str (arg, sval) type(sprintf_arg_t), intent(out) :: arg type(string_t), intent(in) :: sval integer :: i arg%type = ARGTYPE_STR allocate (arg%sval (len (sval) + 1)) do i = 1, len (sval) arg%sval(i) = extract (sval, i, i) end do arg%sval(len (sval) + 1) = c_null_char end subroutine sprintf_arg_init_str @ %def sprintf_arg_init <>= subroutine sprintf_arg_write (arg, unit) type(sprintf_arg_t), intent(in) :: arg integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) select case (arg%type) case (ARGTYPE_NONE) write (u, *) "[none]" case (ARGTYPE_INT) write (u, "(1x,A,1x)", advance = "no") "[int]" write (u, *) arg%ival case (ARGTYPE_REAL) write (u, "(1x,A,1x)", advance = "no") "[real]" write (u, *) arg%rval case (ARGTYPE_STR) write (u, "(1x,A,1x,A)", advance = "no") "[string]", '"' write (u, *) arg%rval, '"' end select end subroutine sprintf_arg_write @ %def sprintf_arg_write @ Return an upper bound for the length of the printed version; in case of strings the result is exact. <>= elemental function sprintf_arg_get_length (arg) result (length) integer :: length type(sprintf_arg_t), intent(in) :: arg select case (arg%type) case (ARGTYPE_INT) length = log10 (real (huge (arg%ival(1)))) + 2 case (ARGTYPE_REAL) length = log10 (real (radix (arg%rval(1))) ** digits (arg%rval(1))) + 8 case (ARGTYPE_STR) length = size (arg%sval) case default length = 0 end select end function sprintf_arg_get_length @ %def sprintf_arg_get_length <>= subroutine sprintf_arg_apply_sprintf (arg, fmt, result, actual_length) type(sprintf_arg_t), intent(in) :: arg character(c_char), dimension(:), intent(in) :: fmt character(c_char), dimension(:), intent(inout) :: result integer, intent(out) :: actual_length integer(c_int) :: ival real(c_double) :: rval select case (arg%type) case (ARGTYPE_NONE) actual_length = sprintf_none (result, fmt) case (ARGTYPE_INT) ival = arg%ival(1) actual_length = sprintf_int (result, fmt, ival) case (ARGTYPE_REAL) rval = arg%rval(1) actual_length = sprintf_double (result, fmt, rval) case (ARGTYPE_STR) actual_length = sprintf_str (result, fmt, arg%sval) case default call msg_bug ("sprintf_arg_apply_sprintf called with illegal type") end select if (actual_length < 0) then write (msg_buffer, *) "Format: '", fmt, "'" call msg_message () write (msg_buffer, *) "Output: '", result, "'" call msg_message () call msg_error ("I/O error in sprintf call") actual_length = 0 end if end subroutine sprintf_arg_apply_sprintf @ %def sprintf_arg_apply_sprintf @ \subsubsection{Container type for the output} There is a procedure which chops the format string into pieces that contain at most one conversion specifier. Pairing this with a [[sprintf_arg]] object, we get the actual input to the [[sprintf]] interface. The type below holds this input and can allocate the output string. <>= type :: sprintf_interface_t private character(c_char), dimension(:), allocatable :: input_fmt type(sprintf_arg_t) :: arg character(c_char), dimension(:), allocatable :: output_str integer :: output_str_len = 0 end type sprintf_interface_t @ %def sprintf_fmt_t <>= subroutine sprintf_interface_init (intf, fmt, arg) type(sprintf_interface_t), intent(out) :: intf type(string_t), intent(in) :: fmt type(sprintf_arg_t), intent(in) :: arg integer :: fmt_len, i fmt_len = len (fmt) allocate (intf%input_fmt (fmt_len + 1)) do i = 1, fmt_len intf%input_fmt(i) = extract (fmt, i, i) end do intf%input_fmt(fmt_len+1) = c_null_char intf%arg = arg allocate (intf%output_str (len (fmt) + sprintf_arg_get_length (arg) + 1)) end subroutine sprintf_interface_init @ %def sprintf_interface_init <>= subroutine sprintf_interface_write (intf, unit) type(sprintf_interface_t), intent(in) :: intf integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, *) "Format string = ", '"', intf%input_fmt, '"' write (u, "(1x,A,1x)", advance = "no") "Argument = " call sprintf_arg_write (intf%arg, unit) if (intf%output_str_len > 0) then write (u, *) "Result string = ", & '"', intf%output_str (1:intf%output_str_len), '"' end if end subroutine sprintf_interface_write @ %def sprintf_interface_write @ Return the output string: <>= function sprintf_interface_get_result (intf) result (string) type(string_t) :: string type(sprintf_interface_t), intent(in) :: intf character(kind = c_char, len = max (intf%output_str_len, 0)) :: buffer integer :: i if (intf%output_str_len > 0) then do i = 1, intf%output_str_len buffer(i:i) = intf%output_str(i) end do string = buffer(1:intf%output_str_len) else string = "" end if end function sprintf_interface_get_result @ %def sprintf_interface_get_result <>= subroutine sprintf_interface_apply_sprintf (intf) type(sprintf_interface_t), intent(inout) :: intf call sprintf_arg_apply_sprintf & (intf%arg, intf%input_fmt, intf%output_str, intf%output_str_len) end subroutine sprintf_interface_apply_sprintf @ %def sprintf_interface_apply_sprintf @ Import the interfaces defined in the previous section: <>= <> @ \subsubsection{Scan the format string} Chop it into pieces that contain one conversion specifier each. The zero-th piece contains the part before the first specifier. Check the specifiers and allow only the subset that we support. Also check for an exact match between conversion specifiers and input arguments. The result is an allocated array of [[sprintf_interface]] object; each one contains a piece of the format string and the corresponding argument. <>= subroutine chop_and_check_format_string (fmt, arg, intf) type(string_t), intent(in) :: fmt type(sprintf_arg_t), dimension(:), intent(in) :: arg type(sprintf_interface_t), dimension(:), intent(out), allocatable :: intf integer :: n_args, i type(string_t), dimension(:), allocatable :: split_fmt type(string_t) :: word, buffer, separator integer :: pos, length, l logical :: ok type(sprintf_arg_t) :: arg_null ok = .true. length = 0 n_args = size (arg) allocate (split_fmt (0:n_args)) split_fmt = "" buffer = fmt SCAN_ARGS: do i = 1, n_args FIND_CONVERSION: do call split (buffer, word, "%", separator=separator) if (separator == "") then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "too few conversion specifiers in format string") ok = .false.; exit SCAN_ARGS end if split_fmt(i-1) = split_fmt(i-1) // word if (extract (buffer, 1, 1) /= "%") then split_fmt(i) = "%" exit FIND_CONVERSION else split_fmt(i-1) = split_fmt(i-1) // "%" end if end do FIND_CONVERSION pos = verify (buffer, "#0-+ ") ! Flag characters (zero or more) split_fmt(i) = split_fmt(i) // extract (buffer, 1, pos-1) buffer = remove (buffer, 1, pos-1) pos = verify (buffer, "123456890") ! Field width word = extract (buffer, 1, pos-1) if (len (word) /= 0) then call read_int_from_string (word, len (word), l) length = length + l end if split_fmt(i) = split_fmt(i) // word buffer = remove (buffer, 1, pos-1) if (extract (buffer, 1, 1) == ".") then buffer = remove (buffer, 1, 1) pos = verify (buffer, "1234567890") ! Precision split_fmt(i) = split_fmt(i) // "." // extract (buffer, 1, pos-1) buffer = remove (buffer, 1, pos-1) end if ! Length modifier would come here, but is not allowed select case (char (extract (buffer, 1, 1))) ! conversion specifier case ("d", "i") if (arg(i)%type /= ARGTYPE_INT) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: integer value expected") ok = .false.; exit SCAN_ARGS end if case ("e", "E", "f", "F", "g", "G") if (arg(i)%type /= ARGTYPE_REAL) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: real value expected") ok = .false.; exit SCAN_ARGS end if case ("s") if (arg(i)%type /= ARGTYPE_STR) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: logical or string value expected") ok = .false.; exit SCAN_ARGS end if case default call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "illegal or incomprehensible conversion specifier") ok = .false.; exit SCAN_ARGS end select split_fmt(i) = split_fmt(i) // extract (buffer, 1, 1) buffer = remove (buffer, 1, 1) end do SCAN_ARGS if (ok) then FIND_EXTRA_CONVERSION: do call split (buffer, word, "%", separator=separator) split_fmt(n_args) = split_fmt(n_args) // word // separator if (separator == "") exit FIND_EXTRA_CONVERSION if (extract (buffer, 1, 1) == "%") then split_fmt(n_args) = split_fmt(n_args) // "%" buffer = remove (buffer, 1, 1) else call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "too many conversion specifiers in format string") ok = .false.; exit FIND_EXTRA_CONVERSION end if end do FIND_EXTRA_CONVERSION split_fmt(n_args) = split_fmt(n_args) // buffer allocate (intf (0:n_args)) call sprintf_interface_init (intf(0), split_fmt(0), arg_null) do i = 1, n_args call sprintf_interface_init (intf(i), split_fmt(i), arg(i)) end do else allocate (intf (0)) end if contains subroutine read_int_from_string (word, length, l) type(string_t), intent(in) :: word integer, intent(in) :: length integer, intent(out) :: l character(len=length) :: buffer buffer = word read (buffer, *) l end subroutine read_int_from_string end subroutine chop_and_check_format_string @ %def chop_and_check_format_string @ \subsection{API} <>= public :: sprintf <>= module function sprintf (fmt, arg) result (string) type(string_t) :: string type(string_t), intent(in) :: fmt type(sprintf_arg_t), dimension(:), intent(in) :: arg end function sprintf <>= module function sprintf (fmt, arg) result (string) type(string_t) :: string type(string_t), intent(in) :: fmt type(sprintf_arg_t), dimension(:), intent(in) :: arg type(sprintf_interface_t), dimension(:), allocatable :: intf integer :: i string = "" call chop_and_check_format_string (fmt, arg, intf) if (size (intf) > 0) then do i = 0, ubound (intf, 1) call sprintf_interface_apply_sprintf (intf(i)) string = string // sprintf_interface_get_result (intf(i)) end do end if end function sprintf @ %def sprintf @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[formats_ut.f90]]>>= <> module formats_ut use unit_tests use formats_uti <> <> contains <> end module formats_ut @ %def formats_ut @ <<[[formats_uti.f90]]>>= <> module formats_uti <> <> use formats <> <> <> contains <> end module formats_uti @ %def formats_ut @ API: driver for the unit tests below. <>= public :: format_test <>= subroutine format_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine format_test @ %def format_test <>= call test (format_1, "format_1", & "check formatting routines", & u, results) <>= public :: format_1 <>= subroutine format_1 (u) integer, intent(in) :: u write (u, "(A)") "*** Test 1: a string ***" write (u, "(A)") call test_run (var_str("%s"), 1, [4], ['abcdefghij'], u) write (u, "(A)") "*** Test 2: two integers ***" write (u, "(A)") call test_run (var_str("%d,%d"), 2, [2, 2], ['42', '13'], u) write (u, "(A)") "*** Test 3: floating point number ***" write (u, "(A)") call test_run (var_str("%8.4f"), 1, [3], ['42567.12345'], u) write (u, "(A)") "*** Test 4: general expression ***" call test_run (var_str("%g"), 1, [3], ['3.1415'], u) contains subroutine test_run (fmt, n_args, type, buffer, unit) type(string_t), intent(in) :: fmt integer, intent(in) :: n_args, unit logical :: lval integer :: ival real(default) :: rval integer :: i type(string_t) :: string type(sprintf_arg_t), dimension(:), allocatable :: arg integer, dimension(n_args), intent(in) :: type character(*), dimension(n_args), intent(in) :: buffer write (unit, "(A,A)") "Format string :", char(fmt) write (unit, "(A,I1)") "Number of args:", n_args allocate (arg (n_args)) do i = 1, n_args write (unit, "(A,I1)") "Argument (type ) = ", type(i) select case (type(i)) case (ARGTYPE_LOG) read (buffer(i), *) lval call sprintf_arg_init (arg(i), lval) case (ARGTYPE_INT) read (buffer(i), *) ival call sprintf_arg_init (arg(i), ival) case (ARGTYPE_REAL) read (buffer(i), *) rval call sprintf_arg_init (arg(i), rval) case (ARGTYPE_STR) call sprintf_arg_init (arg(i), var_str (trim (buffer(i)))) end select end do string = sprintf (fmt, arg) write (unit, "(A,A,A)") "Result: '", char (string), "'" deallocate (arg) end subroutine test_run end subroutine format_1 @ %def format_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{CPU timing} The time is stored in a simple derived type which just holds a floating-point number. <<[[cputime.f90]]>>= <> module cputime <> <> <> <> <> <> interface <> end interface end module cputime @ %def cputime <<[[cputime_sub.f90]]>>= <> submodule (cputime) cputime_s use io_units use diagnostics implicit none contains <> end submodule cputime_s @ %def cputime_s @ @ The CPU time is a floating-point number with an arbitrary reference time. It is single precision (default real, not [[real(default)]]). It is measured in seconds. <>= public :: time_t <>= type :: time_t private logical :: known = .false. real :: value = 0 contains <> end type time_t @ %def time_t <>= procedure :: write => time_write <>= module subroutine time_write (object, unit) class(time_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine time_write <>= module subroutine time_write (object, unit) class(time_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "Time in seconds =" if (object%known) then write (u, "(1x,ES10.3)") object%value else write (u, "(1x,A)") "[unknown]" end if end subroutine time_write @ %def time_write @ Set the current time <>= procedure :: set_current => time_set_current <>= module subroutine time_set_current (time) class(time_t), intent(out) :: time end subroutine time_set_current <>= module subroutine time_set_current (time) class(time_t), intent(out) :: time integer :: msecs call system_clock (msecs) time%value = real (msecs) / 1000. time%known = time%value > 0 end subroutine time_set_current @ %def time_set_current @ Assign to a [[real(default]] value. If the time is undefined, return zero. <>= public :: assignment(=) <>= interface assignment(=) module procedure real_assign_time module procedure real_default_assign_time end interface <>= pure module subroutine real_assign_time (r, time) real, intent(out) :: r class(time_t), intent(in) :: time end subroutine real_assign_time pure module subroutine real_default_assign_time (r, time) real(default), intent(out) :: r class(time_t), intent(in) :: time end subroutine real_default_assign_time <>= pure module subroutine real_assign_time (r, time) real, intent(out) :: r class(time_t), intent(in) :: time if (time%known) then r = time%value else r = 0 end if end subroutine real_assign_time pure module subroutine real_default_assign_time (r, time) real(default), intent(out) :: r class(time_t), intent(in) :: time if (time%known) then r = time%value else r = 0 end if end subroutine real_default_assign_time @ %def real_assign_time @ Assign an integer or (single precision) real value to the time object. <>= generic :: assignment(=) => time_assign_from_integer, time_assign_from_real procedure, private :: time_assign_from_integer procedure, private :: time_assign_from_real <>= module subroutine time_assign_from_integer (time, ival) class(time_t), intent(out) :: time integer, intent(in) :: ival end subroutine time_assign_from_integer module subroutine time_assign_from_real (time, rval) class(time_t), intent(out) :: time real, intent(in) :: rval end subroutine time_assign_from_real <>= module subroutine time_assign_from_integer (time, ival) class(time_t), intent(out) :: time integer, intent(in) :: ival time%value = ival time%known = .true. end subroutine time_assign_from_integer module subroutine time_assign_from_real (time, rval) class(time_t), intent(out) :: time real, intent(in) :: rval time%value = rval time%known = .true. end subroutine time_assign_from_real @ %def time_assign_from_real @ Add times and compute time differences. If any input value is undefined, the result is undefined. <>= generic :: operator(-) => subtract_times generic :: operator(+) => add_times procedure, private :: subtract_times procedure, private :: add_times <>= pure module function subtract_times (t_end, t_begin) result (time) type(time_t) :: time class(time_t), intent(in) :: t_end, t_begin end function subtract_times pure module function add_times (t1, t2) result (time) type(time_t) :: time class(time_t), intent(in) :: t1, t2 end function add_times <>= pure module function subtract_times (t_end, t_begin) result (time) type(time_t) :: time class(time_t), intent(in) :: t_end, t_begin if (t_end%known .and. t_begin%known) then time%known = .true. time%value = t_end%value - t_begin%value end if end function subtract_times pure module function add_times (t1, t2) result (time) type(time_t) :: time class(time_t), intent(in) :: t1, t2 if (t1%known .and. t2%known) then time%known = .true. time%value = t1%value + t2%value end if end function add_times @ %def subtract_times @ %def add_times @ Check if a time is known, so we can use it: <>= procedure :: is_known => time_is_known <>= module function time_is_known (time) result (flag) class(time_t), intent(in) :: time logical :: flag end function time_is_known <>= module function time_is_known (time) result (flag) class(time_t), intent(in) :: time logical :: flag flag = time%known end function time_is_known @ %def time_is_known @ We define functions for converting the time into ss / mm:ss / hh:mm:ss / dd:mm:hh:ss. <>= generic :: expand => time_expand_s, time_expand_ms, & time_expand_hms, time_expand_dhms procedure, private :: time_expand_s procedure, private :: time_expand_ms procedure, private :: time_expand_hms procedure, private :: time_expand_dhms <>= module subroutine time_expand_s (time, sec) class(time_t), intent(in) :: time integer, intent(out) :: sec end subroutine time_expand_s module subroutine time_expand_ms (time, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: min, sec end subroutine time_expand_ms module subroutine time_expand_hms (time, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: hour, min, sec end subroutine time_expand_hms module subroutine time_expand_dhms (time, day, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: day, hour, min, sec end subroutine time_expand_dhms <>= module subroutine time_expand_s (time, sec) class(time_t), intent(in) :: time integer, intent(out) :: sec if (time%known) then sec = time%value else call msg_bug ("Time: attempt to expand undefined value") end if end subroutine time_expand_s module subroutine time_expand_ms (time, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: min, sec if (time%known) then if (time%value >= 0) then sec = mod (int (time%value), 60) else sec = - mod (int (- time%value), 60) end if min = time%value / 60 else call msg_bug ("Time: attempt to expand undefined value") end if end subroutine time_expand_ms module subroutine time_expand_hms (time, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: hour, min, sec call time%expand (min, sec) hour = min / 60 if (min >= 0) then min = mod (min, 60) else min = - mod (-min, 60) end if end subroutine time_expand_hms module subroutine time_expand_dhms (time, day, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: day, hour, min, sec call time%expand (hour, min, sec) day = hour / 24 if (hour >= 0) then hour = mod (hour, 24) else hour = - mod (- hour, 24) end if end subroutine time_expand_dhms @ %def time_expand @ Use the above expansions to generate a time string. <>= procedure :: to_string_s => time_to_string_s procedure :: to_string_ms => time_to_string_ms procedure :: to_string_hms => time_to_string_hms procedure :: to_string_dhms => time_to_string_dhms <>= module function time_to_string_s (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str end function time_to_string_s module function time_to_string_ms (time, blank) result (str) class(time_t), intent(in) :: time logical, intent(in), optional :: blank type(string_t) :: str end function time_to_string_ms module function time_to_string_hms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str end function time_to_string_hms module function time_to_string_dhms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str end function time_to_string_dhms <>= module function time_to_string_s (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s call time%expand (s) write (buffer, "(I0,'s')") s str = trim (buffer) end function time_to_string_s module function time_to_string_ms (time, blank) result (str) class(time_t), intent(in) :: time logical, intent(in), optional :: blank type(string_t) :: str character(256) :: buffer integer :: s, m logical :: x_out x_out = .false. if (present (blank)) x_out = blank call time%expand (m, s) write (buffer, "(I0,'m:',I2.2,'s')") m, abs (s) str = trim (buffer) if (x_out) then str = replace (str, len(str)-1, "X") end if end function time_to_string_ms module function time_to_string_hms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s, m, h call time%expand (h, m, s) write (buffer, "(I0,'h:',I2.2,'m:',I2.2,'s')") h, abs (m), abs (s) str = trim (buffer) end function time_to_string_hms module function time_to_string_dhms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s, m, h, d call time%expand (d, h, m, s) write (buffer, "(I0,'d:',I2.2,'h:',I2.2,'m:',I2.2,'s')") & d, abs (h), abs (m), abs (s) str = trim (buffer) end function time_to_string_dhms @ %def time_to_string @ \subsection{Timer} A timer can measure real (wallclock) time differences. The base type corresponds to the result, i.e., time difference. The object contains two further times for start and stop time. <>= public :: timer_t <>= type, extends (time_t) :: timer_t private logical :: running = .false. type(time_t) :: t1, t2 contains <> end type timer_t @ %def timer_t @ Output. If the timer is running, we indicate this, otherwise write just the result. <>= procedure :: write => timer_write <>= module subroutine timer_write (object, unit) class(timer_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine timer_write <>= module subroutine timer_write (object, unit) class(timer_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (object%running) then write (u, "(1x,A)") "Time in seconds = [running]" else call object%time_t%write (u) end if end subroutine timer_write @ %def timer_write @ Start the timer: store the current time in the first entry and adapt the status. We forget any previous values. <>= procedure :: start => timer_start <>= module subroutine timer_start (timer) class(timer_t), intent(out) :: timer end subroutine timer_start <>= module subroutine timer_start (timer) class(timer_t), intent(out) :: timer call timer%t1%set_current () timer%running = .true. end subroutine timer_start @ %def timer_start @ Restart the timer: simply adapt the status, keeping the start time. <>= procedure :: restart => timer_restart <>= module subroutine timer_restart (timer) class(timer_t), intent(inout) :: timer end subroutine timer_restart <>= module subroutine timer_restart (timer) class(timer_t), intent(inout) :: timer if (timer%t1%known .and. .not. timer%running) then timer%running = .true. else call msg_bug ("Timer: restart attempt from wrong status") end if end subroutine timer_restart @ %def timer_start @ Stop the timer: store the current time in the second entry, adapt the status, and compute the elapsed time. <>= procedure :: stop => timer_stop <>= module subroutine timer_stop (timer) class(timer_t), intent(inout) :: timer end subroutine timer_stop <>= module subroutine timer_stop (timer) class(timer_t), intent(inout) :: timer call timer%t2%set_current () timer%running = .false. call timer%evaluate () end subroutine timer_stop @ %def timer_stop @ Manually set the time (for unit test) <>= procedure :: set_test_time1 => timer_set_test_time1 procedure :: set_test_time2 => timer_set_test_time2 <>= module subroutine timer_set_test_time1 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t end subroutine timer_set_test_time1 module subroutine timer_set_test_time2 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t end subroutine timer_set_test_time2 <>= module subroutine timer_set_test_time1 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t timer%t1 = t end subroutine timer_set_test_time1 module subroutine timer_set_test_time2 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t timer%t2 = t end subroutine timer_set_test_time2 @ %def timer_set_test_time1 @ %def timer_set_test_time2 @ This is separate, available for the unit test. <>= procedure :: evaluate => timer_evaluate <>= module subroutine timer_evaluate (timer) class(timer_t), intent(inout) :: timer end subroutine timer_evaluate <>= module subroutine timer_evaluate (timer) class(timer_t), intent(inout) :: timer timer%time_t = timer%t2 - timer%t1 end subroutine timer_evaluate @ %def timer_evaluate @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[cputime_ut.f90]]>>= <> module cputime_ut use unit_tests use cputime_uti <> <> contains <> end module cputime_ut @ %def cputime_ut @ <<[[cputime_uti.f90]]>>= <> module cputime_uti <> use cputime <> <> contains <> end module cputime_uti @ %def cputime_ut @ API: driver for the unit tests below. <>= public :: cputime_test <>= subroutine cputime_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine cputime_test @ %def cputime_test @ \subsubsection{Basic tests} Check basic functions of the time object. The part which we can't check is getting the actual time from the system clock, since the output will not be reproducible. However, we can check time formats and operations. <>= call test (cputime_1, "cputime_1", & "time operations", & u, results) <>= public :: cputime_1 <>= subroutine cputime_1 (u) integer, intent(in) :: u type(time_t) :: time, time1, time2 real :: t integer :: d, h, m, s write (u, "(A)") "* Test output: cputime_1" write (u, "(A)") "* Purpose: check time operations" write (u, "(A)") write (u, "(A)") "* Undefined time" write (u, *) call time%write (u) write (u, *) write (u, "(A)") "* Set time to zero" write (u, *) time = 0 call time%write (u) write (u, *) write (u, "(A)") "* Set time to 1.234 s" write (u, *) time = 1.234 call time%write (u) t = time write (u, "(1x,A,F6.3)") "Time as real =", t write (u, *) write (u, "(A)") "* Compute time difference" write (u, *) time1 = 5.33 time2 = 7.55 time = time2 - time1 call time1%write (u) call time2%write (u) call time%write (u) write (u, *) write (u, "(A)") "* Compute time sum" write (u, *) time = time2 + time1 call time1%write (u) call time2%write (u) call time%write (u) write (u, *) write (u, "(A)") "* Expand time" write (u, *) time1 = ((24 + 1) * 60 + 1) * 60 + 1 time2 = ((3 * 24 + 23) * 60 + 59) * 60 + 59 call time1%expand (s) write (u, 1) "s =", s call time1%expand (m,s) write (u, 1) "ms =", m, s call time1%expand (h,m,s) write (u, 1) "hms =", h, m, s call time1%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s call time2%expand (s) write (u, 1) "s =", s call time2%expand (m,s) write (u, 1) "ms =", m, s call time2%expand (h,m,s) write (u, 1) "hms =", h, m, s call time2%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s write (u, *) write (u, "(A)") "* Expand negative time" write (u, *) time1 = - (((24 + 1) * 60 + 1) * 60 + 1) time2 = - (((3 * 24 + 23) * 60 + 59) * 60 + 59) call time1%expand (s) write (u, 1) "s =", s call time1%expand (m,s) write (u, 1) "ms =", m, s call time1%expand (h,m,s) write (u, 1) "hms =", h, m, s call time1%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s call time2%expand (s) write (u, 1) "s =", s call time2%expand (m,s) write (u, 1) "ms =", m, s call time2%expand (h,m,s) write (u, 1) "hms =", h, m, s call time2%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s 1 format (1x,A,1x,4(I0,:,':')) write (u, *) write (u, "(A)") "* String from time" write (u, *) time1 = ((24 + 1) * 60 + 1) * 60 + 1 time2 = ((3 * 24 + 23) * 60 + 59) * 60 + 59 write (u, "(A)") char (time1%to_string_s ()) write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_hms ()) write (u, "(A)") char (time1%to_string_dhms ()) write (u, "(A)") char (time2%to_string_s ()) write (u, "(A)") char (time2%to_string_ms ()) write (u, "(A)") char (time2%to_string_hms ()) write (u, "(A)") char (time2%to_string_dhms ()) write (u, "(A)") write (u, "(A)") "* Blanking out the last second entry" write (u, "(A)") write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_ms (.true.)) write (u, *) write (u, "(A)") "* String from negative time" write (u, *) time1 = -(((24 + 1) * 60 + 1) * 60 + 1) time2 = -(((3 * 24 + 23) * 60 + 59) * 60 + 59) write (u, "(A)") char (time1%to_string_s ()) write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_hms ()) write (u, "(A)") char (time1%to_string_dhms ()) write (u, "(A)") char (time2%to_string_s ()) write (u, "(A)") char (time2%to_string_ms ()) write (u, "(A)") char (time2%to_string_hms ()) write (u, "(A)") char (time2%to_string_dhms ()) write (u, "(A)") write (u, "(A)") "* Test output end: cputime_1" end subroutine cputime_1 @ %def cputime_1 @ \subsubsection{Timer tests} Check a timer object. <>= call test (cputime_2, "cputime_2", & "timer", & u, results) <>= public :: cputime_2 <>= subroutine cputime_2 (u) integer, intent(in) :: u type(timer_t) :: timer write (u, "(A)") "* Test output: cputime_2" write (u, "(A)") "* Purpose: check timer" write (u, "(A)") write (u, "(A)") "* Undefined timer" write (u, *) call timer%write (u) write (u, *) write (u, "(A)") "* Start timer" write (u, *) call timer%start () call timer%write (u) write (u, *) write (u, "(A)") "* Stop timer (injecting fake timings)" write (u, *) call timer%stop () call timer%set_test_time1 (2) call timer%set_test_time2 (5) call timer%evaluate () call timer%write (u) write (u, *) write (u, "(A)") "* Restart timer" write (u, *) call timer%restart () call timer%write (u) write (u, *) write (u, "(A)") "* Stop timer again (injecting fake timing)" write (u, *) call timer%stop () call timer%set_test_time2 (10) call timer%evaluate () call timer%write (u) write (u, *) write (u, "(A)") "* Test output end: cputime_2" end subroutine cputime_2 @ %def cputime_2 Index: trunk/src/types/types.nw =================================================================== --- trunk/src/types/types.nw (revision 8775) +++ trunk/src/types/types.nw (revision 8776) @@ -1,8146 +1,8147 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: common types and objects %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Sindarin Built-In Types} \includemodulegraph{types} Here, we define a couple of types and objects which are useful both internally for \whizard, and visible to the user, so they correspond to Sindarin types. \begin{description} \item[particle\_specifiers] Expressions for particles and particle alternatives, involving particle names. \item[pdg\_arrays] Integer (PDG) codes for particles. Useful for particle aliases (e.g., 'quark' for $u,d,s$ etc.). \item[jets] Define (pseudo)jets as objects. Functional only if the [[fastjet]] library is linked. (This may change in the future.) \item[subevents] Particle collections built from event records, for use in analysis and other Sindarin expressions \item[analysis] Observables, histograms, and plots. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Particle Specifiers} In this module we introduce a type for specifying a particle or particle alternative. In addition to the particle specifiers (strings separated by colons), the type contains an optional flag [[polarized]] and a string [[decay]]. If the [[polarized]] flag is set, particle polarization information should be kept when generating events for this process. If the [[decay]] string is set, it is the ID of a decay process which should be applied to this particle when generating events. In input/output form, the [[polarized]] flag is indicated by an asterisk [[(*)]] in brackets, and the [[decay]] is indicated by its ID in brackets. The [[read]] and [[write]] procedures in this module are not type-bound but generic procedures which handle scalar and array arguments. <<[[particle_specifiers.f90]]>>= <> module particle_specifiers <> use io_units use diagnostics <> <> <> <> contains <> end module particle_specifiers @ %def particle_specifiers @ \subsection{Base type} This is an abstract type which can hold a single particle or an expression. <>= type, abstract :: prt_spec_expr_t contains <> end type prt_spec_expr_t @ %def prt_expr_t @ Output, as a string. <>= procedure (prt_spec_expr_to_string), deferred :: to_string <>= abstract interface function prt_spec_expr_to_string (object) result (string) import class(prt_spec_expr_t), intent(in) :: object type(string_t) :: string end function prt_spec_expr_to_string end interface @ %def prt_spec_expr_to_string @ Call an [[expand]] method for all enclosed subexpressions (before handling the current expression). <>= procedure (prt_spec_expr_expand_sub), deferred :: expand_sub <>= abstract interface subroutine prt_spec_expr_expand_sub (object) import class(prt_spec_expr_t), intent(inout) :: object end subroutine prt_spec_expr_expand_sub end interface @ %def prt_spec_expr_expand_sub @ \subsection{Wrapper type} This wrapper can hold a particle expression of any kind. We need it so we can make variadic arrays. <>= public :: prt_expr_t <>= type :: prt_expr_t class(prt_spec_expr_t), allocatable :: x contains <> end type prt_expr_t @ %def prt_expr_t @ Output as a string: delegate. <>= procedure :: to_string => prt_expr_to_string <>= recursive function prt_expr_to_string (object) result (string) class(prt_expr_t), intent(in) :: object type(string_t) :: string if (allocated (object%x)) then string = object%x%to_string () else string = "" end if end function prt_expr_to_string @ %def prt_expr_to_string @ Allocate the expression as a particle specifier and copy the value. <>= procedure :: init_spec => prt_expr_init_spec <>= subroutine prt_expr_init_spec (object, spec) class(prt_expr_t), intent(out) :: object type(prt_spec_t), intent(in) :: spec allocate (prt_spec_t :: object%x) select type (x => object%x) type is (prt_spec_t) x = spec end select end subroutine prt_expr_init_spec @ %def prt_expr_init_spec @ Allocate as a list/sum and allocate for a given length <>= procedure :: init_list => prt_expr_init_list procedure :: init_sum => prt_expr_init_sum <>= subroutine prt_expr_init_list (object, n) class(prt_expr_t), intent(out) :: object integer, intent(in) :: n allocate (prt_spec_list_t :: object%x) select type (x => object%x) type is (prt_spec_list_t) allocate (x%expr (n)) end select end subroutine prt_expr_init_list subroutine prt_expr_init_sum (object, n) class(prt_expr_t), intent(out) :: object integer, intent(in) :: n allocate (prt_spec_sum_t :: object%x) select type (x => object%x) type is (prt_spec_sum_t) allocate (x%expr (n)) end select end subroutine prt_expr_init_sum @ %def prt_expr_init_list @ %def prt_expr_init_sum @ Return the number of terms. This is unity, except if the expression is a sum. <>= procedure :: get_n_terms => prt_expr_get_n_terms <>= function prt_expr_get_n_terms (object) result (n) class(prt_expr_t), intent(in) :: object integer :: n if (allocated (object%x)) then select type (x => object%x) type is (prt_spec_sum_t) n = size (x%expr) class default n = 1 end select else n = 0 end if end function prt_expr_get_n_terms @ %def prt_expr_get_n_terms @ Transform one of the terms, as returned by the previous method, to an array of particle specifiers. The array has more than one entry if the selected term is a list. This makes sense only if the expression has been completely expanded, so the list contains only atoms. <>= procedure :: term_to_array => prt_expr_term_to_array <>= recursive subroutine prt_expr_term_to_array (object, array, i) class(prt_expr_t), intent(in) :: object type(prt_spec_t), dimension(:), intent(inout), allocatable :: array integer, intent(in) :: i integer :: j if (allocated (array)) deallocate (array) select type (x => object%x) type is (prt_spec_t) allocate (array (1)) array(1) = x type is (prt_spec_list_t) allocate (array (size (x%expr))) do j = 1, size (array) select type (y => x%expr(j)%x) type is (prt_spec_t) array(j) = y end select end do type is (prt_spec_sum_t) call x%expr(i)%term_to_array (array, 1) end select end subroutine prt_expr_term_to_array @ %def prt_expr_term_to_array @ \subsection{The atomic type} The trivial case is a single particle, including optional decay and polarization attributes. \subsubsection{Definition} The particle is unstable if the [[decay]] array is allocated. The [[polarized]] flag and decays may not be set simultaneously. <>= public :: prt_spec_t <>= type, extends (prt_spec_expr_t) :: prt_spec_t private type(string_t) :: name logical :: polarized = .false. type(string_t), dimension(:), allocatable :: decay contains <> end type prt_spec_t @ %def prt_spec_t @ \subsubsection{I/O} Output. Old-style subroutines. <>= public :: prt_spec_write <>= interface prt_spec_write module procedure prt_spec_write1 module procedure prt_spec_write2 end interface prt_spec_write <>= subroutine prt_spec_write1 (object, unit, advance) type(prt_spec_t), intent(in) :: object integer, intent(in), optional :: unit character(len=*), intent(in), optional :: advance character(3) :: adv integer :: u u = given_output_unit (unit) adv = "yes"; if (present (advance)) adv = advance write (u, "(A)", advance = adv) char (object%to_string ()) end subroutine prt_spec_write1 @ %def prt_spec_write1 @ Write an array as a list of particle specifiers. <>= subroutine prt_spec_write2 (prt_spec, unit, advance) type(prt_spec_t), dimension(:), intent(in) :: prt_spec integer, intent(in), optional :: unit character(len=*), intent(in), optional :: advance character(3) :: adv integer :: u, i u = given_output_unit (unit) adv = "yes"; if (present (advance)) adv = advance do i = 1, size (prt_spec) if (i > 1) write (u, "(A)", advance="no") ", " call prt_spec_write (prt_spec(i), u, advance="no") end do write (u, "(A)", advance = adv) end subroutine prt_spec_write2 @ %def prt_spec_write2 @ Read. Input may be string or array of strings. <>= public :: prt_spec_read <>= interface prt_spec_read module procedure prt_spec_read1 module procedure prt_spec_read2 end interface prt_spec_read @ Read a single particle specifier <>= pure subroutine prt_spec_read1 (prt_spec, string) type(prt_spec_t), intent(out) :: prt_spec type(string_t), intent(in) :: string type(string_t) :: arg, buffer integer :: b1, b2, c, n, i b1 = scan (string, "(") b2 = scan (string, ")") if (b1 == 0) then prt_spec%name = trim (adjustl (string)) else prt_spec%name = trim (adjustl (extract (string, 1, b1-1))) arg = trim (adjustl (extract (string, b1+1, b2-1))) if (arg == "*") then prt_spec%polarized = .true. else n = 0 buffer = arg do if (verify (buffer, " ") == 0) exit n = n + 1 c = scan (buffer, "+") if (c == 0) exit buffer = extract (buffer, c+1) end do allocate (prt_spec%decay (n)) buffer = arg do i = 1, n c = scan (buffer, "+") if (c == 0) c = len (buffer) + 1 prt_spec%decay(i) = trim (adjustl (extract (buffer, 1, c-1))) buffer = extract (buffer, c+1) end do end if end if end subroutine prt_spec_read1 @ %def prt_spec_read1 @ Read a particle specifier array, given as a single string. The array is allocated to the correct size. <>= pure subroutine prt_spec_read2 (prt_spec, string) type(prt_spec_t), dimension(:), intent(out), allocatable :: prt_spec type(string_t), intent(in) :: string type(string_t) :: buffer integer :: c, i, n n = 0 buffer = string do n = n + 1 c = scan (buffer, ",") if (c == 0) exit buffer = extract (buffer, c+1) end do allocate (prt_spec (n)) buffer = string do i = 1, size (prt_spec) c = scan (buffer, ",") if (c == 0) c = len (buffer) + 1 call prt_spec_read (prt_spec(i), & trim (adjustl (extract (buffer, 1, c-1)))) buffer = extract (buffer, c+1) end do end subroutine prt_spec_read2 @ %def prt_spec_read2 @ \subsubsection{Constructor} Initialize a particle specifier. <>= public :: new_prt_spec <>= interface new_prt_spec module procedure new_prt_spec module procedure new_prt_spec_polarized module procedure new_prt_spec_unstable end interface new_prt_spec <>= elemental function new_prt_spec (name) result (prt_spec) type(string_t), intent(in) :: name type(prt_spec_t) :: prt_spec prt_spec%name = name end function new_prt_spec elemental function new_prt_spec_polarized (name, polarized) result (prt_spec) type(string_t), intent(in) :: name logical, intent(in) :: polarized type(prt_spec_t) :: prt_spec prt_spec%name = name prt_spec%polarized = polarized end function new_prt_spec_polarized pure function new_prt_spec_unstable (name, decay) result (prt_spec) type(string_t), intent(in) :: name type(string_t), dimension(:), intent(in) :: decay type(prt_spec_t) :: prt_spec prt_spec%name = name allocate (prt_spec%decay (size (decay))) prt_spec%decay = decay end function new_prt_spec_unstable @ %def new_prt_spec @ \subsubsection{Access Methods} Return the particle name without qualifiers <>= procedure :: get_name => prt_spec_get_name <>= elemental function prt_spec_get_name (prt_spec) result (name) class(prt_spec_t), intent(in) :: prt_spec type(string_t) :: name name = prt_spec%name end function prt_spec_get_name @ %def prt_spec_get_name @ Return the name with qualifiers <>= procedure :: to_string => prt_spec_to_string <>= function prt_spec_to_string (object) result (string) class(prt_spec_t), intent(in) :: object type(string_t) :: string integer :: i string = object%name if (allocated (object%decay)) then string = string // "(" do i = 1, size (object%decay) if (i > 1) string = string // " + " string = string // object%decay(i) end do string = string // ")" else if (object%polarized) then string = string // "(*)" end if end function prt_spec_to_string @ %def prt_spec_to_string @ Return the polarization flag <>= procedure :: is_polarized => prt_spec_is_polarized <>= elemental function prt_spec_is_polarized (prt_spec) result (flag) class(prt_spec_t), intent(in) :: prt_spec logical :: flag flag = prt_spec%polarized end function prt_spec_is_polarized @ %def prt_spec_is_polarized @ The particle is unstable if there is a decay array. <>= procedure :: is_unstable => prt_spec_is_unstable <>= elemental function prt_spec_is_unstable (prt_spec) result (flag) class(prt_spec_t), intent(in) :: prt_spec logical :: flag flag = allocated (prt_spec%decay) end function prt_spec_is_unstable @ %def prt_spec_is_unstable @ Return the number of decay channels <>= procedure :: get_n_decays => prt_spec_get_n_decays <>= elemental function prt_spec_get_n_decays (prt_spec) result (n) class(prt_spec_t), intent(in) :: prt_spec integer :: n if (allocated (prt_spec%decay)) then n = size (prt_spec%decay) else n = 0 end if end function prt_spec_get_n_decays @ %def prt_spec_get_n_decays @ Return the decay channels <>= procedure :: get_decays => prt_spec_get_decays <>= subroutine prt_spec_get_decays (prt_spec, decay) class(prt_spec_t), intent(in) :: prt_spec type(string_t), dimension(:), allocatable, intent(out) :: decay if (allocated (prt_spec%decay)) then allocate (decay (size (prt_spec%decay))) decay = prt_spec%decay else allocate (decay (0)) end if end subroutine prt_spec_get_decays @ %def prt_spec_get_decays @ \subsubsection{Miscellaneous} There is nothing to expand here: <>= procedure :: expand_sub => prt_spec_expand_sub <>= subroutine prt_spec_expand_sub (object) class(prt_spec_t), intent(inout) :: object end subroutine prt_spec_expand_sub @ %def prt_spec_expand_sub @ \subsection{List} A list of particle specifiers, indicating, e.g., the final state of a process. <>= public :: prt_spec_list_t <>= type, extends (prt_spec_expr_t) :: prt_spec_list_t type(prt_expr_t), dimension(:), allocatable :: expr contains <> end type prt_spec_list_t @ %def prt_spec_list_t @ Output: Concatenate the components. Insert brackets if the component is also a list. The components of the [[expr]] array, if any, should all be filled. <>= procedure :: to_string => prt_spec_list_to_string <>= recursive function prt_spec_list_to_string (object) result (string) class(prt_spec_list_t), intent(in) :: object type(string_t) :: string integer :: i string = "" if (allocated (object%expr)) then do i = 1, size (object%expr) if (i > 1) string = string // ", " select type (x => object%expr(i)%x) type is (prt_spec_list_t) string = string // "(" // x%to_string () // ")" class default string = string // x%to_string () end select end do end if end function prt_spec_list_to_string @ %def prt_spec_list_to_string @ Flatten: if there is a subexpression which is also a list, include the components as direct members of the current list. <>= procedure :: flatten => prt_spec_list_flatten <>= subroutine prt_spec_list_flatten (object) class(prt_spec_list_t), intent(inout) :: object type(prt_expr_t), dimension(:), allocatable :: tmp_expr integer :: i, n_flat, i_flat n_flat = 0 do i = 1, size (object%expr) select type (y => object%expr(i)%x) type is (prt_spec_list_t) n_flat = n_flat + size (y%expr) class default n_flat = n_flat + 1 end select end do if (n_flat > size (object%expr)) then allocate (tmp_expr (n_flat)) i_flat = 0 do i = 1, size (object%expr) select type (y => object%expr(i)%x) type is (prt_spec_list_t) tmp_expr (i_flat + 1 : i_flat + size (y%expr)) = y%expr i_flat = i_flat + size (y%expr) class default tmp_expr (i_flat + 1) = object%expr(i) i_flat = i_flat + 1 end select end do end if if (allocated (tmp_expr)) & call move_alloc (from = tmp_expr, to = object%expr) end subroutine prt_spec_list_flatten @ %def prt_spec_list_flatten @ Convert a list of sums into a sum of lists. (Subexpressions which are not sums are left untouched.) <>= subroutine distribute_prt_spec_list (object) class(prt_spec_expr_t), intent(inout), allocatable :: object class(prt_spec_expr_t), allocatable :: new_object integer, dimension(:), allocatable :: n, ii integer :: k, n_expr, n_terms, i_term select type (object) type is (prt_spec_list_t) n_expr = size (object%expr) allocate (n (n_expr), source = 1) allocate (ii (n_expr), source = 1) do k = 1, size (object%expr) select type (y => object%expr(k)%x) type is (prt_spec_sum_t) n(k) = size (y%expr) end select end do n_terms = product (n) if (n_terms > 1) then allocate (prt_spec_sum_t :: new_object) select type (new_object) type is (prt_spec_sum_t) allocate (new_object%expr (n_terms)) do i_term = 1, n_terms allocate (prt_spec_list_t :: new_object%expr(i_term)%x) select type (x => new_object%expr(i_term)%x) type is (prt_spec_list_t) allocate (x%expr (n_expr)) do k = 1, n_expr select type (y => object%expr(k)%x) type is (prt_spec_sum_t) x%expr(k) = y%expr(ii(k)) class default x%expr(k) = object%expr(k) end select end do end select INCR_INDEX: do k = n_expr, 1, -1 if (ii(k) < n(k)) then ii(k) = ii(k) + 1 exit INCR_INDEX else ii(k) = 1 end if end do INCR_INDEX end do end select end if end select if (allocated (new_object)) call move_alloc (from = new_object, to = object) end subroutine distribute_prt_spec_list @ %def distribute_prt_spec_list @ Apply [[expand]] to all components of the list. <>= procedure :: expand_sub => prt_spec_list_expand_sub <>= recursive subroutine prt_spec_list_expand_sub (object) class(prt_spec_list_t), intent(inout) :: object integer :: i if (allocated (object%expr)) then do i = 1, size (object%expr) call object%expr(i)%expand () end do end if end subroutine prt_spec_list_expand_sub @ %def prt_spec_list_expand_sub @ \subsection{Sum} A sum of particle specifiers, indicating, e.g., a sum of final states. <>= public :: prt_spec_sum_t <>= type, extends (prt_spec_expr_t) :: prt_spec_sum_t type(prt_expr_t), dimension(:), allocatable :: expr contains <> end type prt_spec_sum_t @ %def prt_spec_sum_t @ Output: Concatenate the components. Insert brackets if the component is a list or also a sum. The components of the [[expr]] array, if any, should all be filled. <>= procedure :: to_string => prt_spec_sum_to_string <>= recursive function prt_spec_sum_to_string (object) result (string) class(prt_spec_sum_t), intent(in) :: object type(string_t) :: string integer :: i string = "" if (allocated (object%expr)) then do i = 1, size (object%expr) if (i > 1) string = string // " + " select type (x => object%expr(i)%x) type is (prt_spec_list_t) string = string // "(" // x%to_string () // ")" type is (prt_spec_sum_t) string = string // "(" // x%to_string () // ")" class default string = string // x%to_string () end select end do end if end function prt_spec_sum_to_string @ %def prt_spec_sum_to_string @ Flatten: if there is a subexpression which is also a sum, include the components as direct members of the current sum. This is identical to [[prt_spec_list_flatten]] above, except for the type. <>= procedure :: flatten => prt_spec_sum_flatten <>= subroutine prt_spec_sum_flatten (object) class(prt_spec_sum_t), intent(inout) :: object type(prt_expr_t), dimension(:), allocatable :: tmp_expr integer :: i, n_flat, i_flat n_flat = 0 do i = 1, size (object%expr) select type (y => object%expr(i)%x) type is (prt_spec_sum_t) n_flat = n_flat + size (y%expr) class default n_flat = n_flat + 1 end select end do if (n_flat > size (object%expr)) then allocate (tmp_expr (n_flat)) i_flat = 0 do i = 1, size (object%expr) select type (y => object%expr(i)%x) type is (prt_spec_sum_t) tmp_expr (i_flat + 1 : i_flat + size (y%expr)) = y%expr i_flat = i_flat + size (y%expr) class default tmp_expr (i_flat + 1) = object%expr(i) i_flat = i_flat + 1 end select end do end if if (allocated (tmp_expr)) & call move_alloc (from = tmp_expr, to = object%expr) end subroutine prt_spec_sum_flatten @ %def prt_spec_sum_flatten @ Apply [[expand]] to all terms in the sum. <>= procedure :: expand_sub => prt_spec_sum_expand_sub <>= recursive subroutine prt_spec_sum_expand_sub (object) class(prt_spec_sum_t), intent(inout) :: object integer :: i if (allocated (object%expr)) then do i = 1, size (object%expr) call object%expr(i)%expand () end do end if end subroutine prt_spec_sum_expand_sub @ %def prt_spec_sum_expand_sub @ \subsection{Expression Expansion} The [[expand]] method transforms each particle specifier expression into a sum of lists, according to the rules \begin{align} a, (b, c) &\to a, b, c \\ a + (b + c) &\to a + b + c \\ a, b + c &\to (a, b) + (a, c) \end{align} Note that the precedence of comma and plus are opposite to this expansion, so the parentheses in the final expression are necessary. We assume that subexpressions are filled, i.e., arrays are allocated. <>= procedure :: expand => prt_expr_expand <>= recursive subroutine prt_expr_expand (expr) class(prt_expr_t), intent(inout) :: expr if (allocated (expr%x)) then call distribute_prt_spec_list (expr%x) call expr%x%expand_sub () select type (x => expr%x) type is (prt_spec_list_t) call x%flatten () type is (prt_spec_sum_t) call x%flatten () end select end if end subroutine prt_expr_expand @ %def prt_expr_expand @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[particle_specifiers_ut.f90]]>>= <> module particle_specifiers_ut use unit_tests use particle_specifiers_uti <> <> contains <> end module particle_specifiers_ut @ %def particle_specifiers_ut @ <<[[particle_specifiers_uti.f90]]>>= <> module particle_specifiers_uti <> use particle_specifiers <> <> contains <> end module particle_specifiers_uti @ %def particle_specifiers_ut @ API: driver for the unit tests below. <>= public :: particle_specifiers_test <>= subroutine particle_specifiers_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine particle_specifiers_test @ %def particle_specifiers_test @ \subsubsection{Particle specifier array} Define, read and write an array of particle specifiers. <>= call test (particle_specifiers_1, "particle_specifiers_1", & "Handle particle specifiers", & u, results) <>= public :: particle_specifiers_1 <>= subroutine particle_specifiers_1 (u) integer, intent(in) :: u type(prt_spec_t), dimension(:), allocatable :: prt_spec type(string_t), dimension(:), allocatable :: decay type(string_t), dimension(0) :: no_decay integer :: i, j write (u, "(A)") "* Test output: particle_specifiers_1" write (u, "(A)") "* Purpose: Read and write a particle specifier array" write (u, "(A)") allocate (prt_spec (5)) prt_spec = [ & new_prt_spec (var_str ("a")), & new_prt_spec (var_str ("b"), .true.), & new_prt_spec (var_str ("c"), [var_str ("dec1")]), & new_prt_spec (var_str ("d"), [var_str ("dec1"), var_str ("dec2")]), & new_prt_spec (var_str ("e"), no_decay) & ] do i = 1, size (prt_spec) write (u, "(A)") char (prt_spec(i)%to_string ()) end do write (u, "(A)") call prt_spec_read (prt_spec, & var_str (" a, b( *), c( dec1), d (dec1 + dec2 ), e()")) call prt_spec_write (prt_spec, u) do i = 1, size (prt_spec) write (u, "(A)") write (u, "(A,A)") char (prt_spec(i)%get_name ()), ":" write (u, "(A,L1)") "polarized = ", prt_spec(i)%is_polarized () write (u, "(A,L1)") "unstable = ", prt_spec(i)%is_unstable () write (u, "(A,I0)") "n_decays = ", prt_spec(i)%get_n_decays () call prt_spec(i)%get_decays (decay) write (u, "(A)", advance="no") "decays =" do j = 1, size (decay) write (u, "(1x,A)", advance="no") char (decay(j)) end do write (u, "(A)") end do write (u, "(A)") write (u, "(A)") "* Test output end: particle_specifiers_1" end subroutine particle_specifiers_1 @ %def particle_specifiers_1 @ \subsubsection{Particle specifier expressions} Nested expressions (only basic particles, no decay specs). <>= call test (particle_specifiers_2, "particle_specifiers_2", & "Particle specifier expressions", & u, results) <>= public :: particle_specifiers_2 <>= subroutine particle_specifiers_2 (u) integer, intent(in) :: u type(prt_spec_t) :: a, b, c, d, e, f type(prt_expr_t) :: pe1, pe2, pe3 type(prt_expr_t) :: pe4, pe5, pe6, pe7, pe8, pe9 integer :: i type(prt_spec_t), dimension(:), allocatable :: pa write (u, "(A)") "* Test output: particle_specifiers_2" write (u, "(A)") "* Purpose: Create and display particle expressions" write (u, "(A)") write (u, "(A)") "* Basic expressions" write (u, *) a = new_prt_spec (var_str ("a")) b = new_prt_spec (var_str ("b")) c = new_prt_spec (var_str ("c")) d = new_prt_spec (var_str ("d")) e = new_prt_spec (var_str ("e")) f = new_prt_spec (var_str ("f")) call pe1%init_spec (a) write (u, "(A)") char (pe1%to_string ()) call pe2%init_sum (2) select type (x => pe2%x) type is (prt_spec_sum_t) call x%expr(1)%init_spec (a) call x%expr(2)%init_spec (b) end select write (u, "(A)") char (pe2%to_string ()) call pe3%init_list (2) select type (x => pe3%x) type is (prt_spec_list_t) call x%expr(1)%init_spec (a) call x%expr(2)%init_spec (b) end select write (u, "(A)") char (pe3%to_string ()) write (u, *) write (u, "(A)") "* Nested expressions" write (u, *) call pe4%init_list (2) select type (x => pe4%x) type is (prt_spec_list_t) call x%expr(1)%init_sum (2) select type (y => x%expr(1)%x) type is (prt_spec_sum_t) call y%expr(1)%init_spec (a) call y%expr(2)%init_spec (b) end select call x%expr(2)%init_spec (c) end select write (u, "(A)") char (pe4%to_string ()) call pe5%init_list (2) select type (x => pe5%x) type is (prt_spec_list_t) call x%expr(1)%init_list (2) select type (y => x%expr(1)%x) type is (prt_spec_list_t) call y%expr(1)%init_spec (a) call y%expr(2)%init_spec (b) end select call x%expr(2)%init_spec (c) end select write (u, "(A)") char (pe5%to_string ()) call pe6%init_sum (2) select type (x => pe6%x) type is (prt_spec_sum_t) call x%expr(1)%init_spec (a) call x%expr(2)%init_sum (2) select type (y => x%expr(2)%x) type is (prt_spec_sum_t) call y%expr(1)%init_spec (b) call y%expr(2)%init_spec (c) end select end select write (u, "(A)") char (pe6%to_string ()) call pe7%init_list (2) select type (x => pe7%x) type is (prt_spec_list_t) call x%expr(1)%init_sum (2) select type (y => x%expr(1)%x) type is (prt_spec_sum_t) call y%expr(1)%init_spec (a) call y%expr(2)%init_list (2) select type (z => y%expr(2)%x) type is (prt_spec_list_t) call z%expr(1)%init_spec (b) call z%expr(2)%init_spec (c) end select end select call x%expr(2)%init_spec (d) end select write (u, "(A)") char (pe7%to_string ()) call pe8%init_sum (2) select type (x => pe8%x) type is (prt_spec_sum_t) call x%expr(1)%init_list (2) select type (y => x%expr(1)%x) type is (prt_spec_list_t) call y%expr(1)%init_spec (a) call y%expr(2)%init_spec (b) end select call x%expr(2)%init_list (2) select type (y => x%expr(2)%x) type is (prt_spec_list_t) call y%expr(1)%init_spec (c) call y%expr(2)%init_spec (d) end select end select write (u, "(A)") char (pe8%to_string ()) call pe9%init_list (3) select type (x => pe9%x) type is (prt_spec_list_t) call x%expr(1)%init_sum (2) select type (y => x%expr(1)%x) type is (prt_spec_sum_t) call y%expr(1)%init_spec (a) call y%expr(2)%init_spec (b) end select call x%expr(2)%init_spec (c) call x%expr(3)%init_sum (3) select type (y => x%expr(3)%x) type is (prt_spec_sum_t) call y%expr(1)%init_spec (d) call y%expr(2)%init_spec (e) call y%expr(3)%init_spec (f) end select end select write (u, "(A)") char (pe9%to_string ()) write (u, *) write (u, "(A)") "* Expand as sum" write (u, *) call pe1%expand () write (u, "(A)") char (pe1%to_string ()) call pe4%expand () write (u, "(A)") char (pe4%to_string ()) call pe5%expand () write (u, "(A)") char (pe5%to_string ()) call pe6%expand () write (u, "(A)") char (pe6%to_string ()) call pe7%expand () write (u, "(A)") char (pe7%to_string ()) call pe8%expand () write (u, "(A)") char (pe8%to_string ()) call pe9%expand () write (u, "(A)") char (pe9%to_string ()) write (u, *) write (u, "(A)") "* Transform to arrays:" write (u, "(A)") "* Atomic specifier" do i = 1, pe1%get_n_terms () call pe1%term_to_array (pa, i) call prt_spec_write (pa, u) end do write (u, *) write (u, "(A)") "* List" do i = 1, pe5%get_n_terms () call pe5%term_to_array (pa, i) call prt_spec_write (pa, u) end do write (u, *) write (u, "(A)") "* Sum of atoms" do i = 1, pe6%get_n_terms () call pe6%term_to_array (pa, i) call prt_spec_write (pa, u) end do write (u, *) write (u, "(A)") "* Sum of lists" do i = 1, pe9%get_n_terms () call pe9%term_to_array (pa, i) call prt_spec_write (pa, u) end do write (u, "(A)") write (u, "(A)") "* Test output end: particle_specifiers_2" end subroutine particle_specifiers_2 @ %def particle_specifiers_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{PDG arrays} For defining aliases, we introduce a special type which holds a set of (integer) PDG codes. <<[[pdg_arrays.f90]]>>= <> module pdg_arrays use io_units use sorting use physics_defs <> <> <> <> contains <> end module pdg_arrays @ %def pdg_arrays @ \subsection{Type definition} Using an allocatable array eliminates the need for initializer and/or finalizer. <>= public :: pdg_array_t <>= type :: pdg_array_t private integer, dimension(:), allocatable :: pdg contains <> end type pdg_array_t @ %def pdg_array_t @ Output <>= public :: pdg_array_write <>= procedure :: write => pdg_array_write <>= subroutine pdg_array_write (aval, unit) class(pdg_array_t), intent(in) :: aval integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance="no") "PDG(" if (allocated (aval%pdg)) then do i = 1, size (aval%pdg) if (i > 1) write (u, "(A)", advance="no") ", " write (u, "(I0)", advance="no") aval%pdg(i) end do end if write (u, "(A)", advance="no") ")" end subroutine pdg_array_write @ %def pdg_array_write @ <>= public :: pdg_array_write_set <>= subroutine pdg_array_write_set (aval, unit) type(pdg_array_t), intent(in), dimension(:) :: aval integer, intent(in), optional :: unit integer :: i do i = 1, size (aval) call aval(i)%write (unit) print *, '' end do end subroutine pdg_array_write_set @ %def pdg_array_write_set @ \subsection{Basic operations} Assignment. We define assignment from and to an integer array. Note that the integer array, if it is the l.h.s., must be declared allocatable by the caller. <>= public :: assignment(=) <>= interface assignment(=) module procedure pdg_array_from_int_array module procedure pdg_array_from_int module procedure int_array_from_pdg_array end interface <>= subroutine pdg_array_from_int_array (aval, iarray) type(pdg_array_t), intent(out) :: aval integer, dimension(:), intent(in) :: iarray allocate (aval%pdg (size (iarray))) aval%pdg = iarray end subroutine pdg_array_from_int_array elemental subroutine pdg_array_from_int (aval, int) type(pdg_array_t), intent(out) :: aval integer, intent(in) :: int allocate (aval%pdg (1)) aval%pdg = int end subroutine pdg_array_from_int subroutine int_array_from_pdg_array (iarray, aval) integer, dimension(:), allocatable, intent(out) :: iarray type(pdg_array_t), intent(in) :: aval if (allocated (aval%pdg)) then allocate (iarray (size (aval%pdg))) iarray = aval%pdg else allocate (iarray (0)) end if end subroutine int_array_from_pdg_array @ %def pdg_array_from_int_array pdg_array_from_int int_array_from_pdg_array @ Allocate space for a PDG array <>= public :: pdg_array_init <>= subroutine pdg_array_init (aval, n_elements) type(pdg_array_t), intent(inout) :: aval integer, intent(in) :: n_elements allocate(aval%pdg(n_elements)) end subroutine pdg_array_init @ %def pdg_array_init @ Deallocate a previously allocated pdg array <>= public :: pdg_array_delete <>= subroutine pdg_array_delete (aval) type(pdg_array_t), intent(inout) :: aval if (allocated (aval%pdg)) deallocate (aval%pdg) end subroutine pdg_array_delete @ %def pdg_array_delete @ Merge two pdg arrays, i.e. append a particle string to another leaving out doublettes <>= public :: pdg_array_merge <>= subroutine pdg_array_merge (aval1, aval2) type(pdg_array_t), intent(inout) :: aval1 type(pdg_array_t), intent(in) :: aval2 type(pdg_array_t) :: aval if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then if (.not. any (aval1%pdg == aval2%pdg)) aval = aval1 // aval2 else if (allocated (aval1%pdg)) then aval = aval1 else if (allocated (aval2%pdg)) then aval = aval2 end if call pdg_array_delete (aval1) aval1 = aval%pdg end subroutine pdg_array_merge @ %def pdg_array_merge @ Length of the array. <>= public :: pdg_array_get_length <>= procedure :: get_length => pdg_array_get_length <>= elemental function pdg_array_get_length (aval) result (n) class(pdg_array_t), intent(in) :: aval integer :: n if (allocated (aval%pdg)) then n = size (aval%pdg) else n = 0 end if end function pdg_array_get_length @ %def pdg_array_get_length @ Return the element with index i. <>= public :: pdg_array_get <>= procedure :: get => pdg_array_get <>= elemental function pdg_array_get (aval, i) result (pdg) class(pdg_array_t), intent(in) :: aval integer, intent(in), optional :: i integer :: pdg if (present (i)) then pdg = aval%pdg(i) else pdg = aval%pdg(1) end if end function pdg_array_get @ %def pdg_array_get @ Explicitly set the element with index i. <>= procedure :: set => pdg_array_set <>= subroutine pdg_array_set (aval, i, pdg) class(pdg_array_t), intent(inout) :: aval integer, intent(in) :: i integer, intent(in) :: pdg aval%pdg(i) = pdg end subroutine pdg_array_set @ %def pdg_array_set @ <>= procedure :: add => pdg_array_add <>= function pdg_array_add (aval, aval_add) result (aval_out) type(pdg_array_t) :: aval_out class(pdg_array_t), intent(in) :: aval type(pdg_array_t), intent(in) :: aval_add integer :: n, n_add, i n = size (aval%pdg) n_add = size (aval_add%pdg) allocate (aval_out%pdg (n + n_add)) aval_out%pdg(1:n) = aval%pdg do i = 1, n_add aval_out%pdg(n+i) = aval_add%pdg(i) end do end function pdg_array_add @ %def pdg_array_add @ Replace element with index [[i]] by a new array of elements. <>= public :: pdg_array_replace <>= procedure :: replace => pdg_array_replace <>= function pdg_array_replace (aval, i, pdg_new) result (aval_new) class(pdg_array_t), intent(in) :: aval integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg_new type(pdg_array_t) :: aval_new integer :: n, l n = size (aval%pdg) l = size (pdg_new) allocate (aval_new%pdg (n + l - 1)) aval_new%pdg(:i-1) = aval%pdg(:i-1) aval_new%pdg(i:i+l-1) = pdg_new aval_new%pdg(i+l:) = aval%pdg(i+1:) end function pdg_array_replace @ %def pdg_array_replace @ Concatenate two PDG arrays <>= public :: operator(//) <>= interface operator(//) module procedure concat_pdg_arrays end interface <>= function concat_pdg_arrays (aval1, aval2) result (aval) type(pdg_array_t) :: aval type(pdg_array_t), intent(in) :: aval1, aval2 integer :: n1, n2 if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then n1 = size (aval1%pdg) n2 = size (aval2%pdg) allocate (aval%pdg (n1 + n2)) aval%pdg(:n1) = aval1%pdg aval%pdg(n1+1:) = aval2%pdg else if (allocated (aval1%pdg)) then aval = aval1 else if (allocated (aval2%pdg)) then aval = aval2 end if end function concat_pdg_arrays @ %def concat_pdg_arrays @ \subsection{Matching} A PDG array matches a given PDG code if the code is present within the array. If either one is zero (UNDEFINED), the match also succeeds. <>= public :: operator(.match.) <>= interface operator(.match.) module procedure pdg_array_match_integer module procedure pdg_array_match_pdg_array end interface @ %def .match. @ Match a single code against the array. <>= elemental function pdg_array_match_integer (aval, pdg) result (flag) logical :: flag type(pdg_array_t), intent(in) :: aval integer, intent(in) :: pdg if (allocated (aval%pdg)) then flag = pdg == UNDEFINED & .or. any (aval%pdg == UNDEFINED) & .or. any (aval%pdg == pdg) else flag = .false. end if end function pdg_array_match_integer @ %def pdg_array_match_integer @ Check if the pdg-number corresponds to a quark <>= public :: is_quark <>= elemental function is_quark (pdg_nr) logical :: is_quark integer, intent(in) :: pdg_nr if (abs (pdg_nr) >= 1 .and. abs (pdg_nr) <= 6) then is_quark = .true. else is_quark = .false. end if end function is_quark @ %def is_quark @ Check if pdg-number corresponds to a gluon <>= public :: is_gluon <>= elemental function is_gluon (pdg_nr) logical :: is_gluon integer, intent(in) :: pdg_nr if (pdg_nr == GLUON) then is_gluon = .true. else is_gluon = .false. end if end function is_gluon @ %def is_gluon @ Check if pdg-number corresponds to a photon <>= public :: is_photon <>= elemental function is_photon (pdg_nr) logical :: is_photon integer, intent(in) :: pdg_nr if (pdg_nr == PHOTON) then is_photon = .true. else is_photon = .false. end if end function is_photon @ %def is_photon @ Check if pdg-number corresponds to a colored particle <>= public :: is_colored <>= elemental function is_colored (pdg_nr) logical :: is_colored integer, intent(in) :: pdg_nr is_colored = is_quark (pdg_nr) .or. is_gluon (pdg_nr) end function is_colored @ %def is_colored @ Check if the pdg-number corresponds to a lepton <>= public :: is_lepton <>= elemental function is_lepton (pdg_nr) logical :: is_lepton integer, intent(in) :: pdg_nr if (abs (pdg_nr) >= ELECTRON .and. & abs (pdg_nr) <= TAU_NEUTRINO) then is_lepton = .true. else is_lepton = .false. end if end function is_lepton @ %def is_lepton @ <>= public :: is_fermion <>= elemental function is_fermion (pdg_nr) logical :: is_fermion integer, intent(in) :: pdg_nr is_fermion = is_lepton(pdg_nr) .or. is_quark(pdg_nr) end function is_fermion @ %def is_fermion @ Check if the pdg-number corresponds to a massless vector boson <>= public :: is_massless_vector <>= elemental function is_massless_vector (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_massless_vector if (pdg_nr == GLUON .or. pdg_nr == PHOTON) then is_massless_vector = .true. else is_massless_vector = .false. end if end function is_massless_vector @ %def is_massless_vector @ Check if pdg-number corresponds to a massive vector boson <>= public :: is_massive_vector <>= elemental function is_massive_vector (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_massive_vector if (abs (pdg_nr) == Z_BOSON .or. abs (pdg_nr) == W_BOSON) then is_massive_vector = .true. else is_massive_vector = .false. end if end function is_massive_vector @ %def is massive_vector @ Check if pdg-number corresponds to a vector boson <>= public :: is_vector <>= elemental function is_vector (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_vector if (is_massless_vector (pdg_nr) .or. is_massive_vector (pdg_nr)) then is_vector = .true. else is_vector = .false. end if end function is_vector @ %def is vector @ Check if particle is elementary. <>= public :: is_elementary <>= elemental function is_elementary (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_elementary if (is_vector (pdg_nr) .or. is_fermion (pdg_nr) .or. pdg_nr == 25) then is_elementary = .true. else is_elementary = .false. end if end function is_elementary @ %def is_elementary @ Check if particle is an EW boson or scalar. <>= public :: is_ew_boson_scalar <>= elemental function is_ew_boson_scalar (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_ew_boson_scalar if (is_photon (pdg_nr) .or. is_massive_vector (pdg_nr) .or. pdg_nr == 25) then is_ew_boson_scalar = .true. else is_ew_boson_scalar = .false. end if end function is_ew_boson_scalar @ %def is_ew_boson_scalar @ Check if particle is strongly interacting <>= procedure :: has_colored_particles => pdg_array_has_colored_particles <>= function pdg_array_has_colored_particles (pdg) result (colored) class(pdg_array_t), intent(in) :: pdg logical :: colored integer :: i, pdg_nr colored = .false. do i = 1, size (pdg%pdg) pdg_nr = pdg%pdg(i) if (is_quark (pdg_nr) .or. is_gluon (pdg_nr)) then colored = .true. exit end if end do end function pdg_array_has_colored_particles @ %def pdg_array_has_colored_particles This function is a convenience function for the determination of possible compatibility of flavor structures of processes with certain orders of QCD and QED/EW coupling constants. It assumes the Standard Model (SM) as underlying physics model. The function is based on a naive counting of external particles which are connected to the process by the specific kind of couplings depending on the underlying theory (QCD and/or QED/EW) of which the corresponding particle is a part of. It is constructed in a way that the exclusion of coupling power combinations is well-defined. <>= public :: query_coupling_powers <>= function query_coupling_powers (flv, a_power, as_power) result (valid) integer, intent(in), dimension(:) :: flv integer, dimension(:, :), allocatable :: power_pair_array integer, dimension(2) :: power_pair_ref integer, intent(in) :: a_power, as_power integer :: i, n_legs, n_gluons, n_quarks, n_gamWZH, n_leptons logical, dimension(:), allocatable :: pairs_included logical :: valid integer :: n_bound power_pair_ref = [a_power, as_power] n_legs = size (flv) allocate (power_pair_array (2, n_legs - 1)) do i = 1, n_legs - 1 power_pair_array (1, i) = n_legs - 1 - i power_pair_array (2, i) = i - 1 end do allocate (pairs_included (n_legs - 1)) pairs_included = .true. n_gluons = count (is_gluon (flv)) n_gamWZH = count (is_ew_boson_scalar (flv)) n_quarks = count (is_quark (flv)) n_leptons = count (is_lepton (flv)) if (n_gluons >= 1 .and. n_gluons <= 3) then do i = 1, n_gluons pairs_included (i) = .false. end do else if (n_gluons > 2 .and. n_quarks <= 2 .and. n_gluons + n_quarks == n_legs) then do i = 1, n_legs - 2 pairs_included (i) = .false. end do end if n_bound = 0 if (n_gamWZH + n_leptons == n_legs) then n_bound = n_gamWZH + n_leptons - 2 else if (n_quarks == 2 .and. n_leptons + n_quarks + n_gamWZH == n_legs) then n_bound = n_legs - 2 else if (n_gamWZH + n_leptons > 0) then n_bound = int (n_leptons/2.) + n_gamWZH end if if (n_bound > 0) then do i = 1, n_bound pairs_included (n_legs - i) = .false. end do end if if (n_quarks == 4 .and. .not. qcd_ew_interferences (flv)) then do i = 1, 2 pairs_included (n_legs - i) = .false. end do end if valid = .false. do i = 1, n_legs - 1 if (all (power_pair_array (:, i) == power_pair_ref) .and. pairs_included (i)) then valid = .true. exit end if end do end function query_coupling_powers @ %def query_coupling_powers This functions checks if there is a flavor structure which possibly can induce QCD-EW interference amplitudes. It evaluates to [[true]] if there are at least 2 quark pairs whereby the quarks of at least one quark pair must have the same flavor. <>= public :: qcd_ew_interferences <>= function qcd_ew_interferences (flv) result (valid) integer, intent(in), dimension(:) :: flv integer :: i, n_pairs logical :: valid, qqbar_pair n_pairs = 0 valid = .false. qqbar_pair = .false. if (count (is_quark (flv)) >= 4) then do i = DOWN_Q, TOP_Q qqbar_pair = count (abs (flv) == i) >= 2 if (qqbar_pair) n_pairs = n_pairs + 1 if (n_pairs > 0) then valid = .true. exit end if end do end if end function qcd_ew_interferences @ %def qcd_ew_interferences @ Match two arrays. Succeeds if any pair of entries matches. <>= function pdg_array_match_pdg_array (aval1, aval2) result (flag) logical :: flag type(pdg_array_t), intent(in) :: aval1, aval2 if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then flag = any (aval1 .match. aval2%pdg) else flag = .false. end if end function pdg_array_match_pdg_array @ %def pdg_array_match_pdg_array @ Comparison. Here, we take the PDG arrays as-is, assuming that they are sorted. The ordering is a bit odd: first, we look only at the absolute values of the PDG codes. If they all match, the particle comes before the antiparticle, scanning from left to right. <>= public :: operator(<) public :: operator(>) public :: operator(<=) public :: operator(>=) public :: operator(==) public :: operator(/=) <>= interface operator(<) module procedure pdg_array_lt end interface interface operator(>) module procedure pdg_array_gt end interface interface operator(<=) module procedure pdg_array_le end interface interface operator(>=) module procedure pdg_array_ge end interface interface operator(==) module procedure pdg_array_eq end interface interface operator(/=) module procedure pdg_array_ne end interface <>= elemental function pdg_array_lt (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag integer :: i if (size (aval1%pdg) /= size (aval2%pdg)) then flag = size (aval1%pdg) < size (aval2%pdg) else do i = 1, size (aval1%pdg) if (abs (aval1%pdg(i)) /= abs (aval2%pdg(i))) then flag = abs (aval1%pdg(i)) < abs (aval2%pdg(i)) return end if end do do i = 1, size (aval1%pdg) if (aval1%pdg(i) /= aval2%pdg(i)) then flag = aval1%pdg(i) > aval2%pdg(i) return end if end do flag = .false. end if end function pdg_array_lt elemental function pdg_array_gt (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag flag = .not. (aval1 < aval2 .or. aval1 == aval2) end function pdg_array_gt elemental function pdg_array_le (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag flag = aval1 < aval2 .or. aval1 == aval2 end function pdg_array_le elemental function pdg_array_ge (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag flag = .not. (aval1 < aval2) end function pdg_array_ge elemental function pdg_array_eq (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag if (size (aval1%pdg) /= size (aval2%pdg)) then flag = .false. else flag = all (aval1%pdg == aval2%pdg) end if end function pdg_array_eq elemental function pdg_array_ne (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag flag = .not. (aval1 == aval2) end function pdg_array_ne @ Equivalence. Two PDG arrays are equivalent if either one contains [[UNDEFINED]] or if each element of array 1 is present in array 2, and vice versa. <>= public :: operator(.eqv.) public :: operator(.neqv.) <>= interface operator(.eqv.) module procedure pdg_array_equivalent end interface interface operator(.neqv.) module procedure pdg_array_inequivalent end interface <>= elemental function pdg_array_equivalent (aval1, aval2) result (eq) logical :: eq type(pdg_array_t), intent(in) :: aval1, aval2 logical, dimension(:), allocatable :: match1, match2 integer :: i if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then eq = any (aval1%pdg == UNDEFINED) & .or. any (aval2%pdg == UNDEFINED) if (.not. eq) then allocate (match1 (size (aval1%pdg))) allocate (match2 (size (aval2%pdg))) match1 = .false. match2 = .false. do i = 1, size (aval1%pdg) match2 = match2 .or. aval1%pdg(i) == aval2%pdg end do do i = 1, size (aval2%pdg) match1 = match1 .or. aval2%pdg(i) == aval1%pdg end do eq = all (match1) .and. all (match2) end if else eq = .false. end if end function pdg_array_equivalent elemental function pdg_array_inequivalent (aval1, aval2) result (neq) logical :: neq type(pdg_array_t), intent(in) :: aval1, aval2 neq = .not. pdg_array_equivalent (aval1, aval2) end function pdg_array_inequivalent @ %def pdg_array_equivalent @ \subsection{Sorting} Sort a PDG array by absolute value, particle before antiparticle. After sorting, we eliminate double entries. <>= public :: sort_abs <>= interface sort_abs module procedure pdg_array_sort_abs end interface <>= procedure :: sort_abs => pdg_array_sort_abs <>= function pdg_array_sort_abs (aval1, unique) result (aval2) class(pdg_array_t), intent(in) :: aval1 logical, intent(in), optional :: unique type(pdg_array_t) :: aval2 integer, dimension(:), allocatable :: tmp logical, dimension(:), allocatable :: mask integer :: i, n logical :: uni uni = .false.; if (present (unique)) uni = unique n = size (aval1%pdg) if (uni) then allocate (tmp (n), mask(n)) tmp = sort_abs (aval1%pdg) mask(1) = .true. do i = 2, n mask(i) = tmp(i) /= tmp(i-1) end do allocate (aval2%pdg (count (mask))) aval2%pdg = pack (tmp, mask) else allocate (aval2%pdg (n)) aval2%pdg = sort_abs (aval1%pdg) end if end function pdg_array_sort_abs @ %def sort_abs @ <>= procedure :: intersect => pdg_array_intersect <>= function pdg_array_intersect (aval1, match) result (aval2) class(pdg_array_t), intent(in) :: aval1 integer, dimension(:) :: match type(pdg_array_t) :: aval2 integer, dimension(:), allocatable :: isec integer :: i isec = pack (aval1%pdg, [(any(aval1%pdg(i) == match), i=1,size(aval1%pdg))]) aval2 = isec end function pdg_array_intersect @ %def pdg_array_intersect @ <>= procedure :: search_for_particle => pdg_array_search_for_particle <>= elemental function pdg_array_search_for_particle (pdg, i_part) result (found) class(pdg_array_t), intent(in) :: pdg integer, intent(in) :: i_part logical :: found found = any (pdg%pdg == i_part) end function pdg_array_search_for_particle @ %def pdg_array_search_for_particle @ <>= procedure :: invert => pdg_array_invert <>= function pdg_array_invert (pdg) result (pdg_inverse) class(pdg_array_t), intent(in) :: pdg type(pdg_array_t) :: pdg_inverse integer :: i, n n = size (pdg%pdg) allocate (pdg_inverse%pdg (n)) do i = 1, n select case (pdg%pdg(i)) case (GLUON, PHOTON, Z_BOSON, 25) pdg_inverse%pdg(i) = pdg%pdg(i) case default pdg_inverse%pdg(i) = -pdg%pdg(i) end select end do end function pdg_array_invert @ %def pdg_array_invert @ \subsection{PDG array list} A PDG array list, or PDG list, is an array of PDG-array objects with some convenience methods. <>= public :: pdg_list_t <>= type :: pdg_list_t type(pdg_array_t), dimension(:), allocatable :: a contains <> end type pdg_list_t @ %def pdg_list_t @ Output, as a comma-separated list without advancing I/O. <>= procedure :: write => pdg_list_write <>= subroutine pdg_list_write (object, unit) class(pdg_list_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) if (allocated (object%a)) then do i = 1, size (object%a) if (i > 1) write (u, "(A)", advance="no") ", " call object%a(i)%write (u) end do end if end subroutine pdg_list_write @ %def pdg_list_write @ Initialize for a certain size. The entries are initially empty PDG arrays. <>= generic :: init => pdg_list_init_size procedure, private :: pdg_list_init_size <>= subroutine pdg_list_init_size (pl, n) class(pdg_list_t), intent(out) :: pl integer, intent(in) :: n allocate (pl%a (n)) end subroutine pdg_list_init_size @ %def pdg_list_init_size @ Initialize with a definite array of PDG codes. That is, each entry in the list becomes a single-particle PDG array. <>= generic :: init => pdg_list_init_int_array procedure, private :: pdg_list_init_int_array <>= subroutine pdg_list_init_int_array (pl, pdg) class(pdg_list_t), intent(out) :: pl integer, dimension(:), intent(in) :: pdg integer :: i allocate (pl%a (size (pdg))) do i = 1, size (pdg) pl%a(i) = pdg(i) end do end subroutine pdg_list_init_int_array @ %def pdg_list_init_array @ Set one of the entries. No bounds-check. <>= generic :: set => pdg_list_set_int generic :: set => pdg_list_set_int_array generic :: set => pdg_list_set_pdg_array procedure, private :: pdg_list_set_int procedure, private :: pdg_list_set_int_array procedure, private :: pdg_list_set_pdg_array <>= subroutine pdg_list_set_int (pl, i, pdg) class(pdg_list_t), intent(inout) :: pl integer, intent(in) :: i integer, intent(in) :: pdg pl%a(i) = pdg end subroutine pdg_list_set_int subroutine pdg_list_set_int_array (pl, i, pdg) class(pdg_list_t), intent(inout) :: pl integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg pl%a(i) = pdg end subroutine pdg_list_set_int_array subroutine pdg_list_set_pdg_array (pl, i, pa) class(pdg_list_t), intent(inout) :: pl integer, intent(in) :: i type(pdg_array_t), intent(in) :: pa pl%a(i) = pa end subroutine pdg_list_set_pdg_array @ %def pdg_list_set @ Array size, not the length of individual entries <>= procedure :: get_size => pdg_list_get_size <>= function pdg_list_get_size (pl) result (n) class(pdg_list_t), intent(in) :: pl integer :: n if (allocated (pl%a)) then n = size (pl%a) else n = 0 end if end function pdg_list_get_size @ %def pdg_list_get_size @ Return an entry, as a PDG array. <>= procedure :: get => pdg_list_get <>= function pdg_list_get (pl, i) result (pa) type(pdg_array_t) :: pa class(pdg_list_t), intent(in) :: pl integer, intent(in) :: i pa = pl%a(i) end function pdg_list_get @ %def pdg_list_get @ Check if the list entries are all either mutually disjoint or identical. The individual entries (PDG arrays) should already be sorted, so we can test for equality. <>= procedure :: is_regular => pdg_list_is_regular <>= function pdg_list_is_regular (pl) result (flag) class(pdg_list_t), intent(in) :: pl logical :: flag integer :: i, j, s s = pl%get_size () flag = .true. do i = 1, s do j = i + 1, s if (pl%a(i) .match. pl%a(j)) then if (pl%a(i) /= pl%a(j)) then flag = .false. return end if end if end do end do end function pdg_list_is_regular @ %def pdg_list_is_regular @ Sort the list. First, each entry gets sorted, including elimination of doublers. Then, we sort the list, using the first member of each PDG array as the marker. No removal of doublers at this stage. If [[n_in]] is supplied, we do not reorder the first [[n_in]] particle entries. <>= procedure :: sort_abs => pdg_list_sort_abs <>= function pdg_list_sort_abs (pl, n_in) result (pl_sorted) class(pdg_list_t), intent(in) :: pl integer, intent(in), optional :: n_in type(pdg_list_t) :: pl_sorted type(pdg_array_t), dimension(:), allocatable :: pa integer, dimension(:), allocatable :: pdg, map integer :: i, n0 call pl_sorted%init (pl%get_size ()) if (allocated (pl%a)) then allocate (pa (size (pl%a))) do i = 1, size (pl%a) pa(i) = pl%a(i)%sort_abs (unique = .true.) end do allocate (pdg (size (pa)), source = 0) do i = 1, size (pa) if (allocated (pa(i)%pdg)) then if (size (pa(i)%pdg) > 0) then pdg(i) = pa(i)%pdg(1) end if end if end do if (present (n_in)) then n0 = n_in else n0 = 0 end if allocate (map (size (pdg))) map(:n0) = [(i, i = 1, n0)] map(n0+1:) = n0 + order_abs (pdg(n0+1:)) do i = 1, size (pa) call pl_sorted%set (i, pa(map(i))) end do end if end function pdg_list_sort_abs @ %def pdg_list_sort_abs @ Compare sorted lists: equality. The result is undefined if some entries are not allocated. <>= generic :: operator (==) => pdg_list_eq procedure, private :: pdg_list_eq <>= function pdg_list_eq (pl1, pl2) result (flag) class(pdg_list_t), intent(in) :: pl1, pl2 logical :: flag integer :: i flag = .false. if (allocated (pl1%a) .and. allocated (pl2%a)) then if (size (pl1%a) == size (pl2%a)) then do i = 1, size (pl1%a) associate (a1 => pl1%a(i), a2 => pl2%a(i)) if (allocated (a1%pdg) .and. allocated (a2%pdg)) then if (size (a1%pdg) == size (a2%pdg)) then if (size (a1%pdg) > 0) then if (a1%pdg(1) /= a2%pdg(1)) return end if else return end if else return end if end associate end do flag = .true. end if end if end function pdg_list_eq @ %def pdg_list_eq @ Compare sorted lists. The result is undefined if some entries are not allocated. The ordering is quite complicated. First, a shorter list comes before a longer list. Comparing entry by entry, a shorter entry comes first. Next, we check the first PDG code within corresponding entries. This is compared by absolute value. If equal, particle comes before antiparticle. Finally, if all is equal, the result is false. <>= generic :: operator (<) => pdg_list_lt procedure, private :: pdg_list_lt <>= function pdg_list_lt (pl1, pl2) result (flag) class(pdg_list_t), intent(in) :: pl1, pl2 logical :: flag integer :: i flag = .false. if (allocated (pl1%a) .and. allocated (pl2%a)) then if (size (pl1%a) < size (pl2%a)) then flag = .true.; return else if (size (pl1%a) > size (pl2%a)) then return else do i = 1, size (pl1%a) associate (a1 => pl1%a(i), a2 => pl2%a(i)) if (allocated (a1%pdg) .and. allocated (a2%pdg)) then if (size (a1%pdg) < size (a2%pdg)) then flag = .true.; return else if (size (a1%pdg) > size (a2%pdg)) then return else if (size (a1%pdg) > 0) then if (abs (a1%pdg(1)) < abs (a2%pdg(1))) then flag = .true.; return else if (abs (a1%pdg(1)) > abs (a2%pdg(1))) then return else if (a1%pdg(1) > 0 .and. a2%pdg(1) < 0) then flag = .true.; return else if (a1%pdg(1) < 0 .and. a2%pdg(1) > 0) then return end if end if end if else return end if end associate end do flag = .false. end if end if end function pdg_list_lt @ %def pdg_list_lt @ Replace an entry. In the result, the entry [[#i]] is replaced by the contents of the second argument. The result is not sorted. If [[n_in]] is also set and [[i]] is less or equal to [[n_in]], replace [[#i]] only by the first entry of [[pl_insert]], and insert the remainder after entry [[n_in]]. <>= procedure :: replace => pdg_list_replace <>= function pdg_list_replace (pl, i, pl_insert, n_in) result (pl_out) type(pdg_list_t) :: pl_out class(pdg_list_t), intent(in) :: pl integer, intent(in) :: i class(pdg_list_t), intent(in) :: pl_insert integer, intent(in), optional :: n_in integer :: n, n_insert, n_out, k n = pl%get_size () n_insert = pl_insert%get_size () n_out = n + n_insert - 1 call pl_out%init (n_out) ! if (allocated (pl%a)) then do k = 1, i - 1 pl_out%a(k) = pl%a(k) end do ! end if if (present (n_in)) then pl_out%a(i) = pl_insert%a(1) do k = i + 1, n_in pl_out%a(k) = pl%a(k) end do do k = 1, n_insert - 1 pl_out%a(n_in+k) = pl_insert%a(1+k) end do do k = 1, n - n_in pl_out%a(n_in+k+n_insert-1) = pl%a(n_in+k) end do else ! if (allocated (pl_insert%a)) then do k = 1, n_insert pl_out%a(i-1+k) = pl_insert%a(k) end do ! end if ! if (allocated (pl%a)) then do k = 1, n - i pl_out%a(i+n_insert-1+k) = pl%a(i+k) end do end if ! end if end function pdg_list_replace @ %def pdg_list_replace @ <>= procedure :: fusion => pdg_list_fusion <>= function pdg_list_fusion (pl, pl_insert, i, check_if_existing) result (pl_out) type(pdg_list_t) :: pl_out class(pdg_list_t), intent(in) :: pl type(pdg_list_t), intent(in) :: pl_insert integer, intent(in) :: i logical, intent(in) :: check_if_existing integer :: n, n_insert, k, n_out logical :: new_pdg n = pl%get_size () n_insert = pl_insert%get_size () new_pdg = .not. check_if_existing .or. & (.not. any (pl%search_for_particle (pl_insert%a(1)%pdg))) call pl_out%init (n + n_insert - 1) do k = 1, n if (new_pdg .and. k == i) then pl_out%a(k) = pl%a(k)%add (pl_insert%a(1)) else pl_out%a(k) = pl%a(k) end if end do do k = n + 1, n + n_insert - 1 pl_out%a(k) = pl_insert%a(k-n) end do end function pdg_list_fusion @ %def pdg_list_fusion @ <>= procedure :: get_pdg_sizes => pdg_list_get_pdg_sizes <>= function pdg_list_get_pdg_sizes (pl) result (i_size) integer, dimension(:), allocatable :: i_size class(pdg_list_t), intent(in) :: pl integer :: i, n n = pl%get_size () allocate (i_size (n)) do i = 1, n i_size(i) = size (pl%a(i)%pdg) end do end function pdg_list_get_pdg_sizes @ %def pdg_list_get_pdg_sizes @ Replace the entries of [[pl]] by the matching entries of [[pl_match]], one by one. This is done in-place. If there is no match, return failure. <>= procedure :: match_replace => pdg_list_match_replace <>= subroutine pdg_list_match_replace (pl, pl_match, success) class(pdg_list_t), intent(inout) :: pl class(pdg_list_t), intent(in) :: pl_match logical, intent(out) :: success integer :: i, j success = .true. SCAN_ENTRIES: do i = 1, size (pl%a) do j = 1, size (pl_match%a) if (pl%a(i) .match. pl_match%a(j)) then pl%a(i) = pl_match%a(j) cycle SCAN_ENTRIES end if end do success = .false. return end do SCAN_ENTRIES end subroutine pdg_list_match_replace @ %def pdg_list_match_replace @ Just check if a PDG array matches any entry in the PDG list. The second version returns the position of the match within the list. An optional mask indicates the list elements that should be checked. <>= generic :: operator (.match.) => pdg_list_match_pdg_array procedure, private :: pdg_list_match_pdg_array procedure :: find_match => pdg_list_find_match_pdg_array <>= function pdg_list_match_pdg_array (pl, pa) result (flag) class(pdg_list_t), intent(in) :: pl type(pdg_array_t), intent(in) :: pa logical :: flag flag = pl%find_match (pa) /= 0 end function pdg_list_match_pdg_array function pdg_list_find_match_pdg_array (pl, pa, mask) result (i) class(pdg_list_t), intent(in) :: pl type(pdg_array_t), intent(in) :: pa logical, dimension(:), intent(in), optional :: mask integer :: i do i = 1, size (pl%a) if (present (mask)) then if (.not. mask(i)) cycle end if if (pl%a(i) .match. pa) return end do i = 0 end function pdg_list_find_match_pdg_array @ %def pdg_list_match_pdg_array @ %def pdg_list_find_match_pdg_array @ Some old compilers have problems with allocatable arrays as intent(out) or as function result, so be conservative here: <>= procedure :: create_pdg_array => pdg_list_create_pdg_array <>= subroutine pdg_list_create_pdg_array (pl, pdg) class(pdg_list_t), intent(in) :: pl type(pdg_array_t), dimension(:), intent(inout), allocatable :: pdg integer :: n_elements integer :: i associate (a => pl%a) n_elements = size (a) if (allocated (pdg)) deallocate (pdg) allocate (pdg (n_elements)) do i = 1, n_elements pdg(i) = a(i) end do end associate end subroutine pdg_list_create_pdg_array @ %def pdg_list_create_pdg_array @ <>= procedure :: create_antiparticles => pdg_list_create_antiparticles <>= subroutine pdg_list_create_antiparticles (pl, pl_anti, n_new_particles) class(pdg_list_t), intent(in) :: pl type(pdg_list_t), intent(out) :: pl_anti integer, intent(out) :: n_new_particles type(pdg_list_t) :: pl_inverse integer :: i, n integer :: n_identical logical, dimension(:), allocatable :: collect n = pl%get_size (); n_identical = 0 allocate (collect (n)); collect = .true. call pl_inverse%init (n) do i = 1, n pl_inverse%a(i) = pl%a(i)%invert() end do do i = 1, n if (any (pl_inverse%a(i) == pl%a)) then collect(i) = .false. n_identical = n_identical + 1 end if end do n_new_particles = n - n_identical if (n_new_particles > 0) then call pl_anti%init (n_new_particles) do i = 1, n if (collect (i)) pl_anti%a(i) = pl_inverse%a(i) end do end if end subroutine pdg_list_create_antiparticles @ %def pdg_list_create_antiparticles @ <>= procedure :: search_for_particle => pdg_list_search_for_particle <>= elemental function pdg_list_search_for_particle (pl, i_part) result (found) logical :: found class(pdg_list_t), intent(in) :: pl integer, intent(in) :: i_part integer :: i_pl do i_pl = 1, size (pl%a) found = pl%a(i_pl)%search_for_particle (i_part) if (found) return end do end function pdg_list_search_for_particle @ %def pdg_list_search_for_particle @ <>= procedure :: contains_colored_particles => pdg_list_contains_colored_particles <>= function pdg_list_contains_colored_particles (pl) result (colored) class(pdg_list_t), intent(in) :: pl logical :: colored integer :: i colored = .false. do i = 1, size (pl%a) if (pl%a(i)%has_colored_particles()) then colored = .true. exit end if end do end function pdg_list_contains_colored_particles @ %def pdg_list_contains_colored_particles @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[pdg_arrays_ut.f90]]>>= <> module pdg_arrays_ut use unit_tests use pdg_arrays_uti <> <> contains <> end module pdg_arrays_ut @ %def pdg_arrays_ut @ <<[[pdg_arrays_uti.f90]]>>= <> module pdg_arrays_uti use pdg_arrays <> <> contains <> end module pdg_arrays_uti @ %def pdg_arrays_ut @ API: driver for the unit tests below. <>= public :: pdg_arrays_test <>= subroutine pdg_arrays_test (u, results) integer, intent(in) :: u type (test_results_t), intent(inout) :: results <> end subroutine pdg_arrays_test @ %def pdg_arrays_test @ Basic functionality. <>= call test (pdg_arrays_1, "pdg_arrays_1", & "create and sort PDG array", & u, results) <>= public :: pdg_arrays_1 <>= subroutine pdg_arrays_1 (u) integer, intent(in) :: u type(pdg_array_t) :: pa, pa1, pa2, pa3, pa4, pa5, pa6 integer, dimension(:), allocatable :: pdg write (u, "(A)") "* Test output: pdg_arrays_1" write (u, "(A)") "* Purpose: create and sort PDG arrays" write (u, "(A)") write (u, "(A)") "* Assignment" write (u, "(A)") call pa%write (u) write (u, *) write (u, "(A,I0)") "length = ", pa%get_length () pdg = pa write (u, "(A,3(1x,I0))") "contents = ", pdg write (u, *) pa = 1 call pa%write (u) write (u, *) write (u, "(A,I0)") "length = ", pa%get_length () pdg = pa write (u, "(A,3(1x,I0))") "contents = ", pdg write (u, *) pa = [1, 2, 3] call pa%write (u) write (u, *) write (u, "(A,I0)") "length = ", pa%get_length () pdg = pa write (u, "(A,3(1x,I0))") "contents = ", pdg write (u, "(A,I0)") "element #2 = ", pa%get (2) write (u, *) write (u, "(A)") "* Replace" write (u, *) pa = pa%replace (2, [-5, 5, -7]) call pa%write (u) write (u, *) write (u, *) write (u, "(A)") "* Sort" write (u, *) pa = [1, -7, 3, -5, 5, 3] call pa%write (u) write (u, *) pa1 = pa%sort_abs () pa2 = pa%sort_abs (unique = .true.) call pa1%write (u) write (u, *) call pa2%write (u) write (u, *) write (u, *) write (u, "(A)") "* Compare" write (u, *) pa1 = [1, 3] pa2 = [1, 2, -2] pa3 = [1, 2, 4] pa4 = [1, 2, 4] pa5 = [1, 2, -4] pa6 = [1, 2, -3] write (u, "(A,6(1x,L1))") "< ", & pa1 < pa2, pa2 < pa3, pa3 < pa4, pa4 < pa5, pa5 < pa6, pa6 < pa1 write (u, "(A,6(1x,L1))") "> ", & pa1 > pa2, pa2 > pa3, pa3 > pa4, pa4 > pa5, pa5 > pa6, pa6 > pa1 write (u, "(A,6(1x,L1))") "<=", & pa1 <= pa2, pa2 <= pa3, pa3 <= pa4, pa4 <= pa5, pa5 <= pa6, pa6 <= pa1 write (u, "(A,6(1x,L1))") ">=", & pa1 >= pa2, pa2 >= pa3, pa3 >= pa4, pa4 >= pa5, pa5 >= pa6, pa6 >= pa1 write (u, "(A,6(1x,L1))") "==", & pa1 == pa2, pa2 == pa3, pa3 == pa4, pa4 == pa5, pa5 == pa6, pa6 == pa1 write (u, "(A,6(1x,L1))") "/=", & pa1 /= pa2, pa2 /= pa3, pa3 /= pa4, pa4 /= pa5, pa5 /= pa6, pa6 /= pa1 write (u, *) pa1 = [0] pa2 = [1, 2] pa3 = [1, -2] write (u, "(A,6(1x,L1))") "eqv ", & pa1 .eqv. pa1, pa1 .eqv. pa2, & pa2 .eqv. pa2, pa2 .eqv. pa3 write (u, "(A,6(1x,L1))") "neqv", & pa1 .neqv. pa1, pa1 .neqv. pa2, & pa2 .neqv. pa2, pa2 .neqv. pa3 write (u, *) write (u, "(A,6(1x,L1))") "match", & pa1 .match. 0, pa1 .match. 1, & pa2 .match. 0, pa2 .match. 1, pa2 .match. 3 write (u, "(A)") write (u, "(A)") "* Test output end: pdg_arrays_1" end subroutine pdg_arrays_1 @ %def pdg_arrays_1 @ PDG array list, i.e., arrays of arrays. <>= call test (pdg_arrays_2, "pdg_arrays_2", & "create and sort PDG lists", & u, results) <>= public :: pdg_arrays_2 <>= subroutine pdg_arrays_2 (u) integer, intent(in) :: u type(pdg_array_t) :: pa type(pdg_list_t) :: pl, pl1 write (u, "(A)") "* Test output: pdg_arrays_2" write (u, "(A)") "* Purpose: create and sort PDG lists" write (u, "(A)") write (u, "(A)") "* Assignment" write (u, "(A)") call pl%init (3) call pl%set (1, 42) call pl%set (2, [3, 2]) pa = [5, -5] call pl%set (3, pa) call pl%write (u) write (u, *) write (u, "(A,I0)") "size = ", pl%get_size () write (u, "(A)") write (u, "(A)") "* Sort" write (u, "(A)") pl = pl%sort_abs () call pl%write (u) write (u, *) write (u, "(A)") write (u, "(A)") "* Extract item #3" write (u, "(A)") pa = pl%get (3) call pa%write (u) write (u, *) write (u, "(A)") write (u, "(A)") "* Replace item #3" write (u, "(A)") call pl1%init (2) call pl1%set (1, [2, 4]) call pl1%set (2, -7) pl = pl%replace (3, pl1) call pl%write (u) write (u, *) write (u, "(A)") write (u, "(A)") "* Test output end: pdg_arrays_2" end subroutine pdg_arrays_2 @ %def pdg_arrays_2 @ Check if a (sorted) PDG array lists is regular. The entries (PDG arrays) must not overlap, unless they are identical. <>= call test (pdg_arrays_3, "pdg_arrays_3", & "check PDG lists", & u, results) <>= public :: pdg_arrays_3 <>= subroutine pdg_arrays_3 (u) integer, intent(in) :: u type(pdg_list_t) :: pl write (u, "(A)") "* Test output: pdg_arrays_3" write (u, "(A)") "* Purpose: check for regular PDG lists" write (u, "(A)") write (u, "(A)") "* Regular list" write (u, "(A)") call pl%init (4) call pl%set (1, [1, 2]) call pl%set (2, [1, 2]) call pl%set (3, [5, -5]) call pl%set (4, 42) call pl%write (u) write (u, *) write (u, "(L1)") pl%is_regular () write (u, "(A)") write (u, "(A)") "* Irregular list" write (u, "(A)") call pl%init (4) call pl%set (1, [1, 2]) call pl%set (2, [1, 2]) call pl%set (3, [2, 5, -5]) call pl%set (4, 42) call pl%write (u) write (u, *) write (u, "(L1)") pl%is_regular () write (u, "(A)") write (u, "(A)") "* Test output end: pdg_arrays_3" end subroutine pdg_arrays_3 @ %def pdg_arrays_3 @ Compare PDG array lists. The lists must be regular, i.e., sorted and with non-overlapping (or identical) entries. <>= call test (pdg_arrays_4, "pdg_arrays_4", & "compare PDG lists", & u, results) <>= public :: pdg_arrays_4 <>= subroutine pdg_arrays_4 (u) integer, intent(in) :: u type(pdg_list_t) :: pl1, pl2, pl3 write (u, "(A)") "* Test output: pdg_arrays_4" write (u, "(A)") "* Purpose: check for regular PDG lists" write (u, "(A)") write (u, "(A)") "* Create lists" write (u, "(A)") call pl1%init (4) call pl1%set (1, [1, 2]) call pl1%set (2, [1, 2]) call pl1%set (3, [5, -5]) call pl1%set (4, 42) write (u, "(I1,1x)", advance = "no") 1 call pl1%write (u) write (u, *) call pl2%init (2) call pl2%set (1, 3) call pl2%set (2, [5, -5]) write (u, "(I1,1x)", advance = "no") 2 call pl2%write (u) write (u, *) call pl3%init (2) call pl3%set (1, 4) call pl3%set (2, [5, -5]) write (u, "(I1,1x)", advance = "no") 3 call pl3%write (u) write (u, *) write (u, "(A)") write (u, "(A)") "* a == b" write (u, "(A)") write (u, "(2x,A)") "123" write (u, *) write (u, "(I1,1x,4L1)") 1, pl1 == pl1, pl1 == pl2, pl1 == pl3 write (u, "(I1,1x,4L1)") 2, pl2 == pl1, pl2 == pl2, pl2 == pl3 write (u, "(I1,1x,4L1)") 3, pl3 == pl1, pl3 == pl2, pl3 == pl3 write (u, "(A)") write (u, "(A)") "* a < b" write (u, "(A)") write (u, "(2x,A)") "123" write (u, *) write (u, "(I1,1x,4L1)") 1, pl1 < pl1, pl1 < pl2, pl1 < pl3 write (u, "(I1,1x,4L1)") 2, pl2 < pl1, pl2 < pl2, pl2 < pl3 write (u, "(I1,1x,4L1)") 3, pl3 < pl1, pl3 < pl2, pl3 < pl3 write (u, "(A)") write (u, "(A)") "* Test output end: pdg_arrays_4" end subroutine pdg_arrays_4 @ %def pdg_arrays_4 @ Match-replace: translate all entries in the first list into the matching entries of the second list, if there is a match. <>= call test (pdg_arrays_5, "pdg_arrays_5", & "match PDG lists", & u, results) <>= public :: pdg_arrays_5 <>= subroutine pdg_arrays_5 (u) integer, intent(in) :: u type(pdg_list_t) :: pl1, pl2, pl3 logical :: success write (u, "(A)") "* Test output: pdg_arrays_5" write (u, "(A)") "* Purpose: match-replace" write (u, "(A)") write (u, "(A)") "* Create lists" write (u, "(A)") call pl1%init (2) call pl1%set (1, [1, 2]) call pl1%set (2, 42) call pl1%write (u) write (u, *) call pl3%init (2) call pl3%set (1, [42, -42]) call pl3%set (2, [1, 2, 3, 4]) call pl1%match_replace (pl3, success) call pl3%write (u) write (u, "(1x,A,1x,L1,':',1x)", advance="no") "=>", success call pl1%write (u) write (u, *) write (u, *) call pl2%init (2) call pl2%set (1, 9) call pl2%set (2, 42) call pl2%write (u) write (u, *) call pl2%match_replace (pl3, success) call pl3%write (u) write (u, "(1x,A,1x,L1,':',1x)", advance="no") "=>", success call pl2%write (u) write (u, *) write (u, "(A)") write (u, "(A)") "* Test output end: pdg_arrays_5" end subroutine pdg_arrays_5 @ %def pdg_arrays_5 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Jets} The FastJet library is linked externally, if available. The wrapper code is also in a separate directory. Here, we define \whizard-specific procedures and tests. <<[[jets.f90]]>>= <> module jets use fastjet !NODEP! <> <> contains <> end module jets @ %def jets @ \subsection{Re-exported symbols} We use this module as a proxy for the FastJet interface, therefore we re-export some symbols. <>= public :: fastjet_available public :: fastjet_init public :: jet_definition_t public :: pseudojet_t public :: pseudojet_vector_t public :: cluster_sequence_t public :: assignment (=) @ %def jet_definition_t pseudojet_t pseudojet_vector_t cluster_sequence_t @ The initialization routine prints the banner. <>= subroutine fastjet_init () call print_banner () end subroutine fastjet_init @ %def fastjet_init @ The jet algorithm codes (actually, integers) <>= public :: kt_algorithm public :: cambridge_algorithm public :: antikt_algorithm public :: genkt_algorithm public :: cambridge_for_passive_algorithm public :: genkt_for_passive_algorithm public :: ee_kt_algorithm public :: ee_genkt_algorithm public :: plugin_algorithm public :: undefined_jet_algorithm @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[jets_ut.f90]]>>= <> module jets_ut use unit_tests use jets_uti <> <> contains <> end module jets_ut @ %def jets_ut @ <<[[jets_uti.f90]]>>= <> module jets_uti <> use fastjet !NODEP! use jets <> <> contains <> end module jets_uti @ %def jets_ut @ API: driver for the unit tests below. <>= public :: jets_test <>= subroutine jets_test (u, results) integer, intent(in) :: u type (test_results_t), intent(inout) :: results <> end subroutine jets_test @ %def jets_test @ This test is actually the minimal example from the FastJet manual, translated to Fortran. Note that FastJet creates pseudojet vectors, which we mirror in the [[pseudojet_vector_t]], but immediately assign to pseudojet arrays. Without automatic finalization available in the compilers, we should avoid this in actual code and rather introduce intermediate variables for those objects, which we can finalize explicitly. <>= call test (jets_1, "jets_1", & "basic FastJet functionality", & u, results) <>= public :: jets_1 <>= subroutine jets_1 (u) integer, intent(in) :: u type(pseudojet_t), dimension(:), allocatable :: prt, jets, constituents type(jet_definition_t) :: jet_def type(cluster_sequence_t) :: cs integer, parameter :: dp = default integer :: i, j write (u, "(A)") "* Test output: jets_1" write (u, "(A)") "* Purpose: test basic FastJet functionality" write (u, "(A)") write (u, "(A)") "* Print banner" call print_banner () write (u, *) write (u, "(A)") "* Prepare input particles" allocate (prt (3)) call prt(1)%init ( 99._dp, 0.1_dp, 0._dp, 100._dp) call prt(2)%init ( 4._dp,-0.1_dp, 0._dp, 5._dp) call prt(3)%init (-99._dp, 0._dp, 0._dp, 99._dp) write (u, *) write (u, "(A)") "* Define jet algorithm" call jet_def%init (antikt_algorithm, 0.7_dp) write (u, *) write (u, "(A)") "* Cluster particles according to jet algorithm" write (u, *) write (u, "(A,A)") "Clustering with ", jet_def%description () call cs%init (pseudojet_vector (prt), jet_def) write (u, *) write (u, "(A)") "* Sort output jets" jets = sorted_by_pt (cs%inclusive_jets ()) write (u, *) write (u, "(A)") "* Print jet observables and constituents" write (u, *) write (u, "(4x,3(7x,A3))") "pt", "y", "phi" do i = 1, size (jets) write (u, "(A,1x,I0,A,3(1x,F9.5))") & "jet", i, ":", jets(i)%perp (), jets(i)%rap (), jets(i)%phi () constituents = jets(i)%constituents () do j = 1, size (constituents) write (u, "(4x,A,1x,I0,A,F9.5)") & "constituent", j, "'s pt:", constituents(j)%perp () end do do j = 1, size (constituents) call constituents(j)%final () end do end do write (u, *) write (u, "(A)") "* Cleanup" do i = 1, size (prt) call prt(i)%final () end do do i = 1, size (jets) call jets(i)%final () end do call jet_def%final () call cs%final () write (u, "(A)") write (u, "(A)") "* Test output end: jets_1" end subroutine jets_1 @ %def jets_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Subevents} The purpose of subevents is to store the relevant part of the physical event (either partonic or hadronic), and to hold particle selections and combinations which are constructed in cut or analysis expressions. <<[[subevents.f90]]>>= <> module subevents use, intrinsic :: iso_c_binding !NODEP! <> use io_units use format_defs, only: FMT_14, FMT_19 use format_utils, only: pac_fmt + use numeric_utils, only: pacify use physics_defs use sorting use c_particles use lorentz use pdg_arrays use jets <> <> <> <> <> contains <> end module subevents @ %def subevents @ \subsection{Particles} For the purpose of this module, a particle has a type which can indicate a beam, incoming, outgoing, or composite particle, flavor and helicity codes (integer, undefined for composite), four-momentum and invariant mass squared. (Other particles types are used in extended event types, but also defined here.) Furthermore, each particle has an allocatable array of ancestors -- particle indices which indicate the building blocks of a composite particle. For an incoming/outgoing particle, the array contains only the index of the particle itself. For incoming particles, the momentum is inverted before storing it in the particle object. <>= integer, parameter, public :: PRT_UNDEFINED = 0 integer, parameter, public :: PRT_BEAM = -9 integer, parameter, public :: PRT_INCOMING = 1 integer, parameter, public :: PRT_OUTGOING = 2 integer, parameter, public :: PRT_COMPOSITE = 3 integer, parameter, public :: PRT_VIRTUAL = 4 integer, parameter, public :: PRT_RESONANT = 5 integer, parameter, public :: PRT_BEAM_REMNANT = 9 @ %def PRT_UNDEFINED PRT_BEAM @ %def PRT_INCOMING PRT_OUTGOING PRT_COMPOSITE @ %def PRT_COMPOSITE PRT_VIRTUAL PRT_RESONANT @ %def PRT_BEAM_REMNANT @ \subsubsection{The type} We initialize only the type here and mark as unpolarized. The initializers below do the rest. The logicals [[is_b_jet]] and [[is_c_jet]] are true only if [[prt_t]] comes out of the [[subevt_cluster]] routine and fulfils the correct flavor content. <>= public :: prt_t <>= type :: prt_t private integer :: type = PRT_UNDEFINED integer :: pdg logical :: polarized = .false. logical :: colorized = .false. logical :: clustered = .false. logical :: is_b_jet = .false. logical :: is_c_jet = .false. integer :: h type(vector4_t) :: p real(default) :: p2 integer, dimension(:), allocatable :: src integer, dimension(:), allocatable :: col integer, dimension(:), allocatable :: acl end type prt_t @ %def prt_t @ Initializers. Polarization is set separately. Finalizers are not needed. <>= subroutine prt_init_beam (prt, pdg, p, p2, src) type(prt_t), intent(out) :: prt integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in) :: src prt%type = PRT_BEAM call prt_set (prt, pdg, - p, p2, src) end subroutine prt_init_beam subroutine prt_init_incoming (prt, pdg, p, p2, src) type(prt_t), intent(out) :: prt integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in) :: src prt%type = PRT_INCOMING call prt_set (prt, pdg, - p, p2, src) end subroutine prt_init_incoming subroutine prt_init_outgoing (prt, pdg, p, p2, src) type(prt_t), intent(out) :: prt integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in) :: src prt%type = PRT_OUTGOING call prt_set (prt, pdg, p, p2, src) end subroutine prt_init_outgoing subroutine prt_init_composite (prt, p, src) type(prt_t), intent(out) :: prt type(vector4_t), intent(in) :: p integer, dimension(:), intent(in) :: src prt%type = PRT_COMPOSITE call prt_set (prt, 0, p, p**2, src) end subroutine prt_init_composite @ %def prt_init_beam prt_init_incoming prt_init_outgoing prt_init_composite @ This version is for temporary particle objects, so the [[src]] array is not set. <>= public :: prt_init_combine <>= subroutine prt_init_combine (prt, prt1, prt2) type(prt_t), intent(out) :: prt type(prt_t), intent(in) :: prt1, prt2 type(vector4_t) :: p integer, dimension(0) :: src prt%type = PRT_COMPOSITE p = prt1%p + prt2%p call prt_set (prt, 0, p, p**2, src) end subroutine prt_init_combine @ %def prt_init_combine @ Init from a pseudojet object. <>= subroutine prt_init_pseudojet (prt, jet, src, pdg, is_b_jet, is_c_jet) type(prt_t), intent(out) :: prt type(pseudojet_t), intent(in) :: jet integer, dimension(:), intent(in) :: src integer, intent(in) :: pdg logical, intent(in) :: is_b_jet, is_c_jet type(vector4_t) :: p prt%type = PRT_COMPOSITE p = vector4_moving (jet%e(), & vector3_moving ([jet%px(), jet%py(), jet%pz()])) call prt_set (prt, pdg, p, p**2, src) prt%is_b_jet = is_b_jet prt%is_c_jet = is_c_jet prt%clustered = .true. end subroutine prt_init_pseudojet @ %def prt_init_pseudojet @ \subsubsection{Accessing contents} <>= public :: prt_get_pdg <>= elemental function prt_get_pdg (prt) result (pdg) integer :: pdg type(prt_t), intent(in) :: prt pdg = prt%pdg end function prt_get_pdg @ %def prt_get_pdg <>= public :: prt_get_momentum <>= elemental function prt_get_momentum (prt) result (p) type(vector4_t) :: p type(prt_t), intent(in) :: prt p = prt%p end function prt_get_momentum @ %def prt_get_momentum <>= public :: prt_get_msq <>= elemental function prt_get_msq (prt) result (msq) real(default) :: msq type(prt_t), intent(in) :: prt msq = prt%p2 end function prt_get_msq @ %def prt_get_msq <>= public :: prt_is_polarized <>= elemental function prt_is_polarized (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%polarized end function prt_is_polarized @ %def prt_is_polarized <>= public :: prt_get_helicity <>= elemental function prt_get_helicity (prt) result (h) integer :: h type(prt_t), intent(in) :: prt h = prt%h end function prt_get_helicity @ %def prt_get_helicity <>= public :: prt_is_colorized <>= elemental function prt_is_colorized (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%colorized end function prt_is_colorized @ %def prt_is_colorized <>= public :: prt_is_clustered <>= elemental function prt_is_clustered (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%clustered end function prt_is_clustered @ %def prt_is_clustered <>= public :: prt_is_recombinable <>= elemental function prt_is_recombinable (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt_is_parton (prt) .or. & abs(prt%pdg) == TOP_Q .or. & prt_is_lepton (prt) .or. & prt_is_photon (prt) end function prt_is_recombinable @ %def prt_is_recombinable <>= public :: prt_is_photon <>= elemental function prt_is_photon (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%pdg == PHOTON end function prt_is_photon @ %def prt_is_photon We do not take the top quark into account here. <>= public :: prt_is_parton <>= elemental function prt_is_parton (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = abs(prt%pdg) == DOWN_Q .or. & abs(prt%pdg) == UP_Q .or. & abs(prt%pdg) == STRANGE_Q .or. & abs(prt%pdg) == CHARM_Q .or. & abs(prt%pdg) == BOTTOM_Q .or. & prt%pdg == GLUON end function prt_is_parton @ %def prt_is_parton <>= public :: prt_is_lepton <>= elemental function prt_is_lepton (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = abs(prt%pdg) == ELECTRON .or. & abs(prt%pdg) == MUON .or. & abs(prt%pdg) == TAU end function prt_is_lepton @ %def prt_is_lepton <>= public :: prt_is_b_jet <>= elemental function prt_is_b_jet (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%is_b_jet end function prt_is_b_jet @ %def prt_is_b_jet <>= public :: prt_is_c_jet <>= elemental function prt_is_c_jet (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%is_c_jet end function prt_is_c_jet @ %def prt_is_c_jet @ The number of open color (anticolor) lines. We inspect the list of color (anticolor) lines and count the entries that do not appear in the list of anticolors (colors). (There is no check against duplicates; we assume that color line indices are unique.) <>= public :: prt_get_n_col public :: prt_get_n_acl <>= elemental function prt_get_n_col (prt) result (n) integer :: n type(prt_t), intent(in) :: prt integer, dimension(:), allocatable :: col, acl integer :: i n = 0 if (prt%colorized) then do i = 1, size (prt%col) if (all (prt%col(i) /= prt%acl)) n = n + 1 end do end if end function prt_get_n_col elemental function prt_get_n_acl (prt) result (n) integer :: n type(prt_t), intent(in) :: prt integer, dimension(:), allocatable :: col, acl integer :: i n = 0 if (prt%colorized) then do i = 1, size (prt%acl) if (all (prt%acl(i) /= prt%col)) n = n + 1 end do end if end function prt_get_n_acl @ %def prt_get_n_col @ %def prt_get_n_acl @ Return the color and anticolor-flow line indices explicitly. <>= public :: prt_get_color_indices <>= subroutine prt_get_color_indices (prt, col, acl) type(prt_t), intent(in) :: prt integer, dimension(:), allocatable, intent(out) :: col, acl if (prt%colorized) then col = prt%col acl = prt%acl else col = [integer::] acl = [integer::] end if end subroutine prt_get_color_indices @ %def prt_get_color_indices @ \subsubsection{Setting data} Set the PDG, momentum and momentum squared, and ancestors. If allocate-on-assignment is available, this can be simplified. <>= subroutine prt_set (prt, pdg, p, p2, src) type(prt_t), intent(inout) :: prt integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in) :: src prt%pdg = pdg prt%p = p prt%p2 = p2 if (allocated (prt%src)) then if (size (src) /= size (prt%src)) then deallocate (prt%src) allocate (prt%src (size (src))) end if else allocate (prt%src (size (src))) end if prt%src = src end subroutine prt_set @ %def prt_set @ Set the particle PDG code separately. <>= elemental subroutine prt_set_pdg (prt, pdg) type(prt_t), intent(inout) :: prt integer, intent(in) :: pdg prt%pdg = pdg end subroutine prt_set_pdg @ %def prt_set_pdg @ Set the momentum separately. <>= elemental subroutine prt_set_p (prt, p) type(prt_t), intent(inout) :: prt type(vector4_t), intent(in) :: p prt%p = p end subroutine prt_set_p @ %def prt_set_p @ Set the squared invariant mass separately. <>= elemental subroutine prt_set_p2 (prt, p2) type(prt_t), intent(inout) :: prt real(default), intent(in) :: p2 prt%p2 = p2 end subroutine prt_set_p2 @ %def prt_set_p2 @ Set helicity (optional). <>= subroutine prt_polarize (prt, h) type(prt_t), intent(inout) :: prt integer, intent(in) :: h prt%polarized = .true. prt%h = h end subroutine prt_polarize @ %def prt_polarize @ Set color-flow indices (optional). <>= subroutine prt_colorize (prt, col, acl) type(prt_t), intent(inout) :: prt integer, dimension(:), intent(in) :: col, acl prt%colorized = .true. prt%col = col prt%acl = acl end subroutine prt_colorize @ %def prt_colorize @ \subsubsection{Conversion} Transform a [[prt_t]] object into a [[c_prt_t]] object. <>= public :: c_prt <>= interface c_prt module procedure c_prt_from_prt end interface @ %def c_prt <>= elemental function c_prt_from_prt (prt) result (c_prt) type(c_prt_t) :: c_prt type(prt_t), intent(in) :: prt c_prt = prt%p c_prt%type = prt%type c_prt%pdg = prt%pdg if (prt%polarized) then c_prt%polarized = 1 else c_prt%polarized = 0 end if c_prt%h = prt%h end function c_prt_from_prt @ %def c_prt_from_prt @ \subsubsection{Output} <>= public :: prt_write <>= subroutine prt_write (prt, unit, testflag) type(prt_t), intent(in) :: prt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag logical :: pacified type(prt_t) :: tmp character(len=7) :: fmt integer :: u, i call pac_fmt (fmt, FMT_19, FMT_14, testflag) u = given_output_unit (unit); if (u < 0) return pacified = .false. ; if (present (testflag)) pacified = testflag tmp = prt if (pacified) call pacify (tmp) write (u, "(1x,A)", advance="no") "prt(" select case (prt%type) case (PRT_UNDEFINED); write (u, "('?')", advance="no") case (PRT_BEAM); write (u, "('b:')", advance="no") case (PRT_INCOMING); write (u, "('i:')", advance="no") case (PRT_OUTGOING); write (u, "('o:')", advance="no") case (PRT_COMPOSITE); write (u, "('c:')", advance="no") end select select case (prt%type) case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING) if (prt%polarized) then write (u, "(I0,'/',I0,'|')", advance="no") prt%pdg, prt%h else write (u, "(I0,'|')", advance="no") prt%pdg end if end select select case (prt%type) case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING, PRT_COMPOSITE) if (prt%colorized) then write (u, "(*(I0,:,','))", advance="no") prt%col write (u, "('/')", advance="no") write (u, "(*(I0,:,','))", advance="no") prt%acl write (u, "('|')", advance="no") end if end select select case (prt%type) case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING, PRT_COMPOSITE) write (u, "(" // FMT_14 // ",';'," // FMT_14 // ",','," // & FMT_14 // ",','," // FMT_14 // ")", advance="no") tmp%p write (u, "('|'," // fmt // ")", advance="no") tmp%p2 end select if (allocated (prt%src)) then write (u, "('|')", advance="no") do i = 1, size (prt%src) write (u, "(1x,I0)", advance="no") prt%src(i) end do end if if (prt%is_b_jet) then write (u, "('|b jet')", advance="no") end if if (prt%is_c_jet) then write (u, "('|c jet')", advance="no") end if write (u, "(A)") ")" end subroutine prt_write @ %def prt_write @ \subsubsection{Tools} Two particles match if their [[src]] arrays are the same. <>= public :: operator(.match.) <>= interface operator(.match.) module procedure prt_match end interface @ %def .match. <>= elemental function prt_match (prt1, prt2) result (match) logical :: match type(prt_t), intent(in) :: prt1, prt2 if (size (prt1%src) == size (prt2%src)) then match = all (prt1%src == prt2%src) else match = .false. end if end function prt_match @ %def prt_match @ The combine operation makes a pseudoparticle whose momentum is the result of adding (the momenta of) the pair of input particles. We trace the particles from which a particle is built by storing a [[src]] array. Each particle entry in the [[src]] list contains a list of indices which indicates its building blocks. The indices refer to an original list of particles. Index lists are sorted, and they contain no element more than once. We thus require that in a given pseudoparticle, each original particle occurs at most once. The result is intent(inout), so it will not be initialized when the subroutine is entered. If the particles carry color, we recall that the combined particle is a composite which is understood as outgoing. If one of the arguments is an incoming particle, is color entries must be reversed. <>= subroutine prt_combine (prt, prt_in1, prt_in2, ok) type(prt_t), intent(inout) :: prt type(prt_t), intent(in) :: prt_in1, prt_in2 logical :: ok integer, dimension(:), allocatable :: src integer, dimension(:), allocatable :: col1, acl1, col2, acl2 call combine_index_lists (src, prt_in1%src, prt_in2%src) ok = allocated (src) if (ok) then call prt_init_composite (prt, prt_in1%p + prt_in2%p, src) if (prt_in1%colorized .or. prt_in2%colorized) then select case (prt_in1%type) case default call prt_get_color_indices (prt_in1, col1, acl1) case (PRT_BEAM, PRT_INCOMING) call prt_get_color_indices (prt_in1, acl1, col1) end select select case (prt_in2%type) case default call prt_get_color_indices (prt_in2, col2, acl2) case (PRT_BEAM, PRT_INCOMING) call prt_get_color_indices (prt_in2, acl2, col2) end select call prt_colorize (prt, [col1, col2], [acl1, acl2]) end if end if end subroutine prt_combine @ %def prt_combine @ This variant does not produce the combined particle, it just checks whether the combination is valid (no common [[src]] entry). <>= public :: are_disjoint <>= function are_disjoint (prt_in1, prt_in2) result (flag) logical :: flag type(prt_t), intent(in) :: prt_in1, prt_in2 flag = index_lists_are_disjoint (prt_in1%src, prt_in2%src) end function are_disjoint @ %def are_disjoint @ [[src]] Lists with length $>1$ are built by a [[combine]] operation which merges the lists in a sorted manner. If the result would have a duplicate entry, it is discarded, and the result is unallocated. <>= subroutine combine_index_lists (res, src1, src2) integer, dimension(:), intent(in) :: src1, src2 integer, dimension(:), allocatable :: res integer :: i1, i2, i allocate (res (size (src1) + size (src2))) if (size (src1) == 0) then res = src2 return else if (size (src2) == 0) then res = src1 return end if i1 = 1 i2 = 1 LOOP: do i = 1, size (res) if (src1(i1) < src2(i2)) then res(i) = src1(i1); i1 = i1 + 1 if (i1 > size (src1)) then res(i+1:) = src2(i2:) exit LOOP end if else if (src1(i1) > src2(i2)) then res(i) = src2(i2); i2 = i2 + 1 if (i2 > size (src2)) then res(i+1:) = src1(i1:) exit LOOP end if else deallocate (res) exit LOOP end if end do LOOP end subroutine combine_index_lists @ %def combine_index_lists @ This function is similar, but it does not actually merge the list, it just checks whether they are disjoint (no common [[src]] entry). <>= function index_lists_are_disjoint (src1, src2) result (flag) logical :: flag integer, dimension(:), intent(in) :: src1, src2 integer :: i1, i2, i flag = .true. i1 = 1 i2 = 1 LOOP: do i = 1, size (src1) + size (src2) if (src1(i1) < src2(i2)) then i1 = i1 + 1 if (i1 > size (src1)) then exit LOOP end if else if (src1(i1) > src2(i2)) then i2 = i2 + 1 if (i2 > size (src2)) then exit LOOP end if else flag = .false. exit LOOP end if end do LOOP end function index_lists_are_disjoint @ %def index_lists_are_disjoint @ \subsection{subevents} Particles are collected in subevents. This type is implemented as a dynamically allocated array, which need not be completely filled. The value [[n_active]] determines the number of meaningful entries. \subsubsection{Type definition} <>= public :: subevt_t <>= type :: subevt_t private integer :: n_active = 0 type(prt_t), dimension(:), allocatable :: prt contains <> end type subevt_t @ %def subevt_t @ Initialize, allocating with size zero (default) or given size. The number of contained particles is set equal to the size. <>= public :: subevt_init <>= subroutine subevt_init (subevt, n_active) type(subevt_t), intent(out) :: subevt integer, intent(in), optional :: n_active if (present (n_active)) subevt%n_active = n_active allocate (subevt%prt (subevt%n_active)) end subroutine subevt_init @ %def subevt_init @ (Re-)allocate the subevent with some given size. If the size is greater than the previous one, do a real reallocation. Otherwise, just reset the recorded size. Contents are untouched, but become invalid. <>= public :: subevt_reset <>= subroutine subevt_reset (subevt, n_active) type(subevt_t), intent(inout) :: subevt integer, intent(in) :: n_active subevt%n_active = n_active if (subevt%n_active > size (subevt%prt)) then deallocate (subevt%prt) allocate (subevt%prt (subevt%n_active)) end if end subroutine subevt_reset @ %def subevt_reset @ Output. No prefix for the headline 'subevt', because this will usually be printed appending to a previous line. <>= public :: subevt_write <>= procedure :: write => subevt_write <>= subroutine subevt_write (object, unit, prefix, pacified) class(subevt_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "subevent:" do i = 1, object%n_active if (present (prefix)) write (u, "(A)", advance="no") prefix write (u, "(1x,I0)", advance="no") i call prt_write (object%prt(i), unit = unit, testflag = pacified) end do end subroutine subevt_write @ %def subevt_write @ Defined assignment: transfer only meaningful entries. This is a deep copy (as would be default assignment). <>= interface assignment(=) module procedure subevt_assign end interface @ %def = <>= subroutine subevt_assign (subevt, subevt_in) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: subevt_in if (.not. allocated (subevt%prt)) then call subevt_init (subevt, subevt_in%n_active) else call subevt_reset (subevt, subevt_in%n_active) end if subevt%prt(:subevt%n_active) = subevt_in%prt(:subevt%n_active) end subroutine subevt_assign @ %def subevt_assign @ \subsubsection{Fill contents} Store incoming/outgoing particles which are completely defined. <>= public :: subevt_set_beam public :: subevt_set_incoming public :: subevt_set_outgoing public :: subevt_set_composite <>= subroutine subevt_set_beam (subevt, i, pdg, p, p2, src) type(subevt_t), intent(inout) :: subevt integer, intent(in) :: i integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in), optional :: src if (present (src)) then call prt_init_beam (subevt%prt(i), pdg, p, p2, src) else call prt_init_beam (subevt%prt(i), pdg, p, p2, [i]) end if end subroutine subevt_set_beam subroutine subevt_set_incoming (subevt, i, pdg, p, p2, src) type(subevt_t), intent(inout) :: subevt integer, intent(in) :: i integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in), optional :: src if (present (src)) then call prt_init_incoming (subevt%prt(i), pdg, p, p2, src) else call prt_init_incoming (subevt%prt(i), pdg, p, p2, [i]) end if end subroutine subevt_set_incoming subroutine subevt_set_outgoing (subevt, i, pdg, p, p2, src) type(subevt_t), intent(inout) :: subevt integer, intent(in) :: i integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in), optional :: src if (present (src)) then call prt_init_outgoing (subevt%prt(i), pdg, p, p2, src) else call prt_init_outgoing (subevt%prt(i), pdg, p, p2, [i]) end if end subroutine subevt_set_outgoing subroutine subevt_set_composite (subevt, i, p, src) type(subevt_t), intent(inout) :: subevt integer, intent(in) :: i type(vector4_t), intent(in) :: p integer, dimension(:), intent(in) :: src call prt_init_composite (subevt%prt(i), p, src) end subroutine subevt_set_composite @ %def subevt_set_incoming subevt_set_outgoing subevt_set_composite @ Separately assign flavors, simultaneously for all incoming/outgoing particles. <>= public :: subevt_set_pdg_beam public :: subevt_set_pdg_incoming public :: subevt_set_pdg_outgoing <>= subroutine subevt_set_pdg_beam (subevt, pdg) type(subevt_t), intent(inout) :: subevt integer, dimension(:), intent(in) :: pdg integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_BEAM) then call prt_set_pdg (subevt%prt(i), pdg(j)) j = j + 1 if (j > size (pdg)) exit end if end do end subroutine subevt_set_pdg_beam subroutine subevt_set_pdg_incoming (subevt, pdg) type(subevt_t), intent(inout) :: subevt integer, dimension(:), intent(in) :: pdg integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_INCOMING) then call prt_set_pdg (subevt%prt(i), pdg(j)) j = j + 1 if (j > size (pdg)) exit end if end do end subroutine subevt_set_pdg_incoming subroutine subevt_set_pdg_outgoing (subevt, pdg) type(subevt_t), intent(inout) :: subevt integer, dimension(:), intent(in) :: pdg integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_OUTGOING) then call prt_set_pdg (subevt%prt(i), pdg(j)) j = j + 1 if (j > size (pdg)) exit end if end do end subroutine subevt_set_pdg_outgoing @ %def subevt_set_pdg_beam @ %def subevt_set_pdg_incoming @ %def subevt_set_pdg_outgoing @ Separately assign momenta, simultaneously for all incoming/outgoing particles. <>= public :: subevt_set_p_beam public :: subevt_set_p_incoming public :: subevt_set_p_outgoing <>= subroutine subevt_set_p_beam (subevt, p) type(subevt_t), intent(inout) :: subevt type(vector4_t), dimension(:), intent(in) :: p integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_BEAM) then call prt_set_p (subevt%prt(i), p(j)) j = j + 1 if (j > size (p)) exit end if end do end subroutine subevt_set_p_beam subroutine subevt_set_p_incoming (subevt, p) type(subevt_t), intent(inout) :: subevt type(vector4_t), dimension(:), intent(in) :: p integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_INCOMING) then call prt_set_p (subevt%prt(i), p(j)) j = j + 1 if (j > size (p)) exit end if end do end subroutine subevt_set_p_incoming subroutine subevt_set_p_outgoing (subevt, p) type(subevt_t), intent(inout) :: subevt type(vector4_t), dimension(:), intent(in) :: p integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_OUTGOING) then call prt_set_p (subevt%prt(i), p(j)) j = j + 1 if (j > size (p)) exit end if end do end subroutine subevt_set_p_outgoing @ %def subevt_set_p_beam @ %def subevt_set_p_incoming @ %def subevt_set_p_outgoing @ Separately assign the squared invariant mass, simultaneously for all incoming/outgoing particles. <>= public :: subevt_set_p2_beam public :: subevt_set_p2_incoming public :: subevt_set_p2_outgoing <>= subroutine subevt_set_p2_beam (subevt, p2) type(subevt_t), intent(inout) :: subevt real(default), dimension(:), intent(in) :: p2 integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_BEAM) then call prt_set_p2 (subevt%prt(i), p2(j)) j = j + 1 if (j > size (p2)) exit end if end do end subroutine subevt_set_p2_beam subroutine subevt_set_p2_incoming (subevt, p2) type(subevt_t), intent(inout) :: subevt real(default), dimension(:), intent(in) :: p2 integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_INCOMING) then call prt_set_p2 (subevt%prt(i), p2(j)) j = j + 1 if (j > size (p2)) exit end if end do end subroutine subevt_set_p2_incoming subroutine subevt_set_p2_outgoing (subevt, p2) type(subevt_t), intent(inout) :: subevt real(default), dimension(:), intent(in) :: p2 integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_OUTGOING) then call prt_set_p2 (subevt%prt(i), p2(j)) j = j + 1 if (j > size (p2)) exit end if end do end subroutine subevt_set_p2_outgoing @ %def subevt_set_p2_beam @ %def subevt_set_p2_incoming @ %def subevt_set_p2_outgoing @ Set polarization for an entry <>= public :: subevt_polarize <>= subroutine subevt_polarize (subevt, i, h) type(subevt_t), intent(inout) :: subevt integer, intent(in) :: i, h call prt_polarize (subevt%prt(i), h) end subroutine subevt_polarize @ %def subevt_polarize @ Set color-flow indices for an entry <>= public :: subevt_colorize <>= subroutine subevt_colorize (subevt, i, col, acl) type(subevt_t), intent(inout) :: subevt integer, intent(in) :: i, col, acl if (col > 0 .and. acl > 0) then call prt_colorize (subevt%prt(i), [col], [acl]) else if (col > 0) then call prt_colorize (subevt%prt(i), [col], [integer ::]) else if (acl > 0) then call prt_colorize (subevt%prt(i), [integer ::], [acl]) else call prt_colorize (subevt%prt(i), [integer ::], [integer ::]) end if end subroutine subevt_colorize @ %def subevt_colorize @ \subsubsection{Accessing contents} Return true if the subevent has entries. <>= public :: subevt_is_nonempty <>= function subevt_is_nonempty (subevt) result (flag) logical :: flag type(subevt_t), intent(in) :: subevt flag = subevt%n_active /= 0 end function subevt_is_nonempty @ %def subevt_is_nonempty @ Return the number of entries <>= public :: subevt_get_length <>= function subevt_get_length (subevt) result (length) integer :: length type(subevt_t), intent(in) :: subevt length = subevt%n_active end function subevt_get_length @ %def subevt_get_length @ Return a specific particle. The index is not checked for validity. <>= public :: subevt_get_prt <>= function subevt_get_prt (subevt, i) result (prt) type(prt_t) :: prt type(subevt_t), intent(in) :: subevt integer, intent(in) :: i prt = subevt%prt(i) end function subevt_get_prt @ %def subevt_get_prt @ Return the partonic energy squared. We take the particles with flag [[PRT_INCOMING]] and compute their total invariant mass. <>= public :: subevt_get_sqrts_hat <>= function subevt_get_sqrts_hat (subevt) result (sqrts_hat) type(subevt_t), intent(in) :: subevt real(default) :: sqrts_hat type(vector4_t) :: p integer :: i do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_INCOMING) then p = p + prt_get_momentum (subevt%prt(i)) end if end do sqrts_hat = p ** 1 end function subevt_get_sqrts_hat @ %def subevt_get_sqrts_hat @ Return the number of incoming (outgoing) particles, respectively. Beam particles or composites are not counted. <>= public :: subevt_get_n_in public :: subevt_get_n_out <>= function subevt_get_n_in (subevt) result (n_in) type(subevt_t), intent(in) :: subevt integer :: n_in n_in = count (subevt%prt(:subevt%n_active)%type == PRT_INCOMING) end function subevt_get_n_in function subevt_get_n_out (subevt) result (n_out) type(subevt_t), intent(in) :: subevt integer :: n_out n_out = count (subevt%prt(:subevt%n_active)%type == PRT_OUTGOING) end function subevt_get_n_out @ %def subevt_get_n_in @ %def subevt_get_n_out @ <>= interface c_prt module procedure c_prt_from_subevt module procedure c_prt_array_from_subevt end interface @ %def c_prt <>= function c_prt_from_subevt (subevt, i) result (c_prt) type(c_prt_t) :: c_prt type(subevt_t), intent(in) :: subevt integer, intent(in) :: i c_prt = c_prt_from_prt (subevt%prt(i)) end function c_prt_from_subevt function c_prt_array_from_subevt (subevt) result (c_prt_array) type(subevt_t), intent(in) :: subevt type(c_prt_t), dimension(subevt%n_active) :: c_prt_array c_prt_array = c_prt_from_prt (subevt%prt(1:subevt%n_active)) end function c_prt_array_from_subevt @ %def c_prt_from_subevt @ %def c_prt_array_from_subevt @ \subsubsection{Operations with subevents} The join operation joins two subevents. When appending the elements of the second list, we check for each particle whether it is already in the first list. If yes, it is discarded. The result list should be initialized already. If a mask is present, it refers to the second subevent. Particles where the mask is not set are discarded. <>= public :: subevt_join <>= subroutine subevt_join (subevt, pl1, pl2, mask2) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1, pl2 logical, dimension(:), intent(in), optional :: mask2 integer :: n1, n2, i, n n1 = pl1%n_active n2 = pl2%n_active call subevt_reset (subevt, n1 + n2) subevt%prt(:n1) = pl1%prt(:n1) n = n1 if (present (mask2)) then do i = 1, pl2%n_active if (mask2(i)) then if (disjoint (i)) then n = n + 1 subevt%prt(n) = pl2%prt(i) end if end if end do else do i = 1, pl2%n_active if (disjoint (i)) then n = n + 1 subevt%prt(n) = pl2%prt(i) end if end do end if subevt%n_active = n contains function disjoint (i) result (flag) integer, intent(in) :: i logical :: flag integer :: j do j = 1, pl1%n_active if (.not. are_disjoint (pl1%prt(j), pl2%prt(i))) then flag = .false. return end if end do flag = .true. end function disjoint end subroutine subevt_join @ %def subevt_join @ The combine operation makes a subevent whose entries are the result of adding (the momenta of) each pair of particles in the input lists. We trace the particles from which a particles is built by storing a [[src]] array. Each particle entry in the [[src]] list contains a list of indices which indicates its building blocks. The indices refer to an original list of particles. Index lists are sorted, and they contain no element more than once. We thus require that in a given pseudoparticle, each original particle occurs at most once. <>= public :: subevt_combine <>= subroutine subevt_combine (subevt, pl1, pl2, mask12) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1, pl2 logical, dimension(:,:), intent(in), optional :: mask12 integer :: n1, n2, i1, i2, n, j logical :: ok n1 = pl1%n_active n2 = pl2%n_active call subevt_reset (subevt, n1 * n2) n = 1 do i1 = 1, n1 do i2 = 1, n2 if (present (mask12)) then ok = mask12(i1,i2) else ok = .true. end if if (ok) call prt_combine & (subevt%prt(n), pl1%prt(i1), pl2%prt(i2), ok) if (ok) then CHECK_DOUBLES: do j = 1, n - 1 if (subevt%prt(n) .match. subevt%prt(j)) then ok = .false.; exit CHECK_DOUBLES end if end do CHECK_DOUBLES if (ok) n = n + 1 end if end do end do subevt%n_active = n - 1 end subroutine subevt_combine @ %def subevt_combine @ The collect operation makes a single-entry subevent which results from combining (the momenta of) all particles in the input list. As above, the result does not contain an original particle more than once; this is checked for each particle when it is collected. Furthermore, each entry has a mask; where the mask is false, the entry is dropped. (Thus, if the input particles are already composite, there is some chance that the result depends on the order of the input list and is not as expected. This situation should be avoided.) <>= public :: subevt_collect <>= subroutine subevt_collect (subevt, pl1, mask1) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1 logical, dimension(:), intent(in) :: mask1 type(prt_t) :: prt integer :: i logical :: ok call subevt_reset (subevt, 1) subevt%n_active = 0 do i = 1, pl1%n_active if (mask1(i)) then if (subevt%n_active == 0) then subevt%n_active = 1 subevt%prt(1) = pl1%prt(i) else call prt_combine (prt, subevt%prt(1), pl1%prt(i), ok) if (ok) subevt%prt(1) = prt end if end if end do end subroutine subevt_collect @ %def subevt_collect @ The cluster operation is similar to [[collect]], but applies a jet algorithm. The result is a subevent consisting of jets and, possibly, unclustered extra particles. As above, the result does not contain an original particle more than once; this is checked for each particle when it is collected. Furthermore, each entry has a mask; where the mask is false, the entry is dropped. The algorithm: first determine the (pseudo)particles that participate in the clustering. They should not overlap, and the mask entry must be set. We then cluster the particles, using the given jet definition. The result particles are retrieved from the cluster sequence. We still have to determine the source indices for each jet: for each input particle, we get the jet index. Accumulating the source entries for all particles that are part of a given jet, we derive the jet source entries. Finally, we delete the C structures that have been constructed by FastJet and its interface. <>= public :: subevt_cluster <>= subroutine subevt_cluster (subevt, pl1, dcut, mask1, jet_def, & keep_jets, exclusive) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1 real(default), intent(in) :: dcut logical, dimension(:), intent(in) :: mask1 type(jet_definition_t), intent(in) :: jet_def logical, intent(in) :: keep_jets, exclusive integer, dimension(:), allocatable :: map, jet_index type(pseudojet_t), dimension(:), allocatable :: jet_in, jet_out type(pseudojet_vector_t) :: jv_in, jv_out type(cluster_sequence_t) :: cs integer :: i, n_src, n_active call map_prt_index (pl1, mask1, n_src, map) n_active = count (map /= 0) allocate (jet_in (n_active)) allocate (jet_index (n_active)) do i = 1, n_active call jet_in(i)%init (prt_get_momentum (pl1%prt(map(i)))) end do call jv_in%init (jet_in) call cs%init (jv_in, jet_def) if (exclusive) then jv_out = cs%exclusive_jets (dcut) else jv_out = cs%inclusive_jets () end if call cs%assign_jet_indices (jv_out, jet_index) allocate (jet_out (jv_out%size ())) jet_out = jv_out call fill_pseudojet (subevt, pl1, jet_out, jet_index, n_src, map) do i = 1, size (jet_out) call jet_out(i)%final () end do call jv_out%final () call cs%final () call jv_in%final () do i = 1, size (jet_in) call jet_in(i)%final () end do contains ! Uniquely combine sources and add map those new indices to the old ones subroutine map_prt_index (pl1, mask1, n_src, map) type(subevt_t), intent(in) :: pl1 logical, dimension(:), intent(in) :: mask1 integer, intent(out) :: n_src integer, dimension(:), allocatable, intent(out) :: map integer, dimension(:), allocatable :: src, src_tmp integer :: i allocate (src(0)) allocate (map (pl1%n_active), source = 0) n_active = 0 do i = 1, pl1%n_active if (.not. mask1(i)) cycle call combine_index_lists (src_tmp, src, pl1%prt(i)%src) if (.not. allocated (src_tmp)) cycle call move_alloc (from=src_tmp, to=src) n_active = n_active + 1 map(n_active) = i end do n_src = size (src) end subroutine map_prt_index ! Retrieve source(s) of a jet and fill corresponding subevent subroutine fill_pseudojet (subevt, pl1, jet_out, jet_index, n_src, map) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1 type(pseudojet_t), dimension(:), intent(in) :: jet_out integer, dimension(:), intent(in) :: jet_index integer, dimension(:), intent(in) :: map integer, intent(in) :: n_src integer, dimension(n_src) :: src_fill integer :: i, jet, k, combined_pdg, pdg, n_quarks, n_src_fill logical :: is_b, is_c call subevt_reset (subevt, size (jet_out)) do jet = 1, size (jet_out) pdg = 0; src_fill = 0; n_src_fill = 0; combined_pdg = 0; n_quarks = 0 is_b = .false.; is_c = .false. PARTICLE: do i = 1, size (jet_index) if (jet_index(i) /= jet) cycle PARTICLE associate (prt => pl1%prt(map(i)), n_src_prt => size(pl1%prt(map(i))%src)) do k = 1, n_src_prt src_fill(n_src_fill + k) = prt%src(k) end do n_src_fill = n_src_fill + n_src_prt if (is_quark (prt%pdg)) then n_quarks = n_quarks + 1 if (.not. is_b) then if (abs (prt%pdg) == 5) then is_b = .true. is_c = .false. else if (abs (prt%pdg) == 4) then is_c = .true. end if end if if (combined_pdg == 0) combined_pdg = prt%pdg end if end associate end do PARTICLE if (keep_jets .and. n_quarks == 1) pdg = combined_pdg call prt_init_pseudojet (subevt%prt(jet), jet_out(jet), & src_fill(:n_src_fill), pdg, is_b, is_c) end do end subroutine fill_pseudojet end subroutine subevt_cluster @ %def subevt_cluster @ Do recombination. The incoming subevent [[pl]] is left unchanged if it either does not contain photons at all, or consists just of a single photon and nothing else or the photon does have a larger $R>R_0$ distance to the nearest other particle or does not fulfill the [[mask1]] condition. Otherwise, the subevent is one entry shorter and contains a single recombined particle whose original flavor is kept depending on the setting [[keep_flv]]. When this subroutine is called, it is explicitly assumed that there is only one photon. For the moment, we take here the first photon from the subevent to possibly recombine and leave this open for generalization. <>= public :: subevt_recombine <>= subroutine subevt_recombine (subevt, pl, mask1, reco_r0, keep_flv) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl type(prt_t), dimension(:), allocatable :: prt_rec logical, dimension(:), intent(in) :: mask1 logical, intent(in) :: keep_flv real(default), intent(in) :: reco_r0 real(default), dimension(:), allocatable :: del_rij integer, dimension(:), allocatable :: i_sortr type(prt_t) :: prt_gam, prt_comb logical :: recombine, ok integer :: i, n, i_gam, n_gam, n_rec, pdg_orig n = subevt_get_length (pl) n_gam = 0 FIND_FIRST_PHOTON: do i = 1, n if (prt_is_photon (pl%prt (i))) then n_gam = n_gam + 1 prt_gam = pl%prt (i) i_gam = i exit FIND_FIRST_PHOTON end if end do FIND_FIRST_PHOTON n_rec = n - n_gam if (n_gam == 0) then subevt = pl else if (n_rec > 0) then allocate (prt_rec (n_rec)) do i = 1, n_rec if (i == i_gam) cycle if (i < i_gam) then prt_rec(i) = pl%prt(i) else prt_rec(i) = pl%prt(i+n_gam) end if end do allocate (del_rij (n_rec), i_sortr (n_rec)) del_rij(1:n_rec) = eta_phi_distance(prt_get_momentum (prt_gam), & prt_get_momentum (prt_rec(1:n_rec))) i_sortr = order (del_rij) recombine = del_rij (i_sortr (1)) <= reco_r0 .and. mask1(i_gam) if (recombine) then call subevt_reset (subevt, pl%n_active-n_gam) do i = 1, n_rec if (i == i_sortr(1)) then pdg_orig = prt_get_pdg (prt_rec(i_sortr (1))) call prt_combine (prt_comb, prt_gam, prt_rec(i_sortr (1)), ok) if (ok) then subevt%prt(i_sortr (1)) = prt_comb if (keep_flv) call prt_set_pdg & (subevt%prt(i_sortr (1)), pdg_orig) end if else subevt%prt(i) = prt_rec(i) end if end do else subevt = pl end if else subevt = pl end if end if end subroutine subevt_recombine @ %def subevt_recombine @ Return a list of all particles for which the mask is true. <>= public :: subevt_select <>= subroutine subevt_select (subevt, pl, mask1) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl logical, dimension(:), intent(in) :: mask1 integer :: i, n call subevt_reset (subevt, pl%n_active) n = 0 do i = 1, pl%n_active if (mask1(i)) then n = n + 1 subevt%prt(n) = pl%prt(i) end if end do subevt%n_active = n end subroutine subevt_select @ %def subevt_select @ Return a subevent which consists of the single particle with specified [[index]]. If [[index]] is negative, count from the end. If it is out of bounds, return an empty list. <>= public :: subevt_extract <>= subroutine subevt_extract (subevt, pl, index) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl integer, intent(in) :: index if (index > 0) then if (index <= pl%n_active) then call subevt_reset (subevt, 1) subevt%prt(1) = pl%prt(index) else call subevt_reset (subevt, 0) end if else if (index < 0) then if (abs (index) <= pl%n_active) then call subevt_reset (subevt, 1) subevt%prt(1) = pl%prt(pl%n_active + 1 + index) else call subevt_reset (subevt, 0) end if else call subevt_reset (subevt, 0) end if end subroutine subevt_extract @ %def subevt_extract @ Return the list of particles sorted according to increasing values of the provided integer or real array. If no array is given, sort by PDG value. <>= public :: subevt_sort <>= interface subevt_sort module procedure subevt_sort_pdg module procedure subevt_sort_int module procedure subevt_sort_real end interface <>= subroutine subevt_sort_pdg (subevt, pl) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl integer :: n n = subevt%n_active call subevt_sort_int (subevt, pl, abs (3 * subevt%prt(:n)%pdg - 1)) end subroutine subevt_sort_pdg subroutine subevt_sort_int (subevt, pl, ival) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl integer, dimension(:), intent(in) :: ival call subevt_reset (subevt, pl%n_active) subevt%n_active = pl%n_active subevt%prt = pl%prt( order (ival) ) end subroutine subevt_sort_int subroutine subevt_sort_real (subevt, pl, rval) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl real(default), dimension(:), intent(in) :: rval integer :: i integer, dimension(size(rval)) :: idx call subevt_reset (subevt, pl%n_active) subevt%n_active = pl%n_active if (allocated (subevt%prt)) deallocate (subevt%prt) allocate (subevt%prt (size(pl%prt))) idx = order (rval) do i = 1, size (idx) subevt%prt(i) = pl%prt (idx(i)) end do end subroutine subevt_sort_real @ %def subevt_sort @ Return the list of particles which have any of the specified PDG codes (and optionally particle type: beam, incoming, outgoing). <>= public :: subevt_select_pdg_code <>= subroutine subevt_select_pdg_code (subevt, aval, subevt_in, prt_type) type(subevt_t), intent(inout) :: subevt type(pdg_array_t), intent(in) :: aval type(subevt_t), intent(in) :: subevt_in integer, intent(in), optional :: prt_type integer :: n_active, n_match logical, dimension(:), allocatable :: mask integer :: i, j n_active = subevt_in%n_active allocate (mask (n_active)) forall (i = 1:n_active) & mask(i) = aval .match. subevt_in%prt(i)%pdg if (present (prt_type)) & mask = mask .and. subevt_in%prt(:n_active)%type == prt_type n_match = count (mask) call subevt_reset (subevt, n_match) j = 0 do i = 1, n_active if (mask(i)) then j = j + 1 subevt%prt(j) = subevt_in%prt(i) end if end do end subroutine subevt_select_pdg_code @ %def subevt_select_pdg_code @ \subsection{Eliminate numerical noise} This is useful for testing purposes: set entries to zero that are smaller in absolute values than a given tolerance parameter. Note: instead of setting the tolerance in terms of EPSILON (kind-dependent), we fix it to $10^{-16}$, which is the typical value for double precision. The reason is that there are situations where intermediate representations (external libraries, files) are limited to double precision, even if the main program uses higher precision. <>= public :: pacify <>= interface pacify module procedure pacify_prt module procedure pacify_subevt end interface pacify @ %def pacify <>= subroutine pacify_prt (prt) class(prt_t), intent(inout) :: prt real(default) :: e e = max (1E-10_default * energy (prt%p), 1E-13_default) call pacify (prt%p, e) call pacify (prt%p2, 1E3_default * e) end subroutine pacify_prt subroutine pacify_subevt (subevt) class(subevt_t), intent(inout) :: subevt integer :: i do i = 1, subevt%n_active call pacify (subevt%prt(i)) end do end subroutine pacify_subevt @ %def pacify_prt @ %def pacify_subevt @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Analysis tools} This module defines structures useful for data analysis. These include observables, histograms, and plots. Observables are quantities that are calculated and summed up event by event. At the end, one can compute the average and error. Histograms have their bins in addition to the observable properties. Histograms are usually written out in tables and displayed graphically. In plots, each record creates its own entry in a table. This can be used for scatter plots if called event by event, or for plotting dependencies on parameters if called once per integration run. Graphs are container for histograms and plots, which carry their own graphics options. The type layout is still somewhat obfuscated. This would become much simpler if type extension could be used. <<[[analysis.f90]]>>= <> module analysis <> <> use io_units use format_utils, only: quote_underscore, tex_format use system_defs, only: TAB use diagnostics use os_interface use ifiles <> <> <> <> <> <> contains <> end module analysis @ %def analysis @ \subsection{Output formats} These formats share a common field width (alignment). <>= character(*), parameter, public :: HISTOGRAM_HEAD_FORMAT = "1x,A15,3x" character(*), parameter, public :: HISTOGRAM_INTG_FORMAT = "3x,I9,3x" character(*), parameter, public :: HISTOGRAM_DATA_FORMAT = "ES19.12" @ %def HISTOGRAM_HEAD_FORMAT HISTOGRAM_INTG_FORMAT HISTOGRAM_DATA_FORMAT @ \subsection{Graph options} These parameters are used for displaying data. They apply to a whole graph, which may contain more than one plot element. The GAMELAN code chunks are part of both [[graph_options]] and [[drawing_options]]. The [[drawing_options]] copy is used in histograms and plots, also as graph elements. The [[graph_options]] copy is used for [[graph]] objects as a whole. Both copies are usually identical. <>= public :: graph_options_t <>= type :: graph_options_t private type(string_t) :: id type(string_t) :: title type(string_t) :: description type(string_t) :: x_label type(string_t) :: y_label integer :: width_mm = 130 integer :: height_mm = 90 logical :: x_log = .false. logical :: y_log = .false. real(default) :: x_min = 0 real(default) :: x_max = 1 real(default) :: y_min = 0 real(default) :: y_max = 1 logical :: x_min_set = .false. logical :: x_max_set = .false. logical :: y_min_set = .false. logical :: y_max_set = .false. type(string_t) :: gmlcode_bg type(string_t) :: gmlcode_fg end type graph_options_t @ %def graph_options_t @ Initialize the record, all strings are empty. The limits are undefined. <>= public :: graph_options_init <>= subroutine graph_options_init (graph_options) type(graph_options_t), intent(out) :: graph_options graph_options%id = "" graph_options%title = "" graph_options%description = "" graph_options%x_label = "" graph_options%y_label = "" graph_options%gmlcode_bg = "" graph_options%gmlcode_fg = "" end subroutine graph_options_init @ %def graph_options_init @ Set individual options. <>= public :: graph_options_set <>= subroutine graph_options_set (graph_options, id, & title, description, x_label, y_label, width_mm, height_mm, & x_log, y_log, x_min, x_max, y_min, y_max, & gmlcode_bg, gmlcode_fg) type(graph_options_t), intent(inout) :: graph_options type(string_t), intent(in), optional :: id type(string_t), intent(in), optional :: title type(string_t), intent(in), optional :: description type(string_t), intent(in), optional :: x_label, y_label integer, intent(in), optional :: width_mm, height_mm logical, intent(in), optional :: x_log, y_log real(default), intent(in), optional :: x_min, x_max, y_min, y_max type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg if (present (id)) graph_options%id = id if (present (title)) graph_options%title = title if (present (description)) graph_options%description = description if (present (x_label)) graph_options%x_label = x_label if (present (y_label)) graph_options%y_label = y_label if (present (width_mm)) graph_options%width_mm = width_mm if (present (height_mm)) graph_options%height_mm = height_mm if (present (x_log)) graph_options%x_log = x_log if (present (y_log)) graph_options%y_log = y_log if (present (x_min)) graph_options%x_min = x_min if (present (x_max)) graph_options%x_max = x_max if (present (y_min)) graph_options%y_min = y_min if (present (y_max)) graph_options%y_max = y_max if (present (x_min)) graph_options%x_min_set = .true. if (present (x_max)) graph_options%x_max_set = .true. if (present (y_min)) graph_options%y_min_set = .true. if (present (y_max)) graph_options%y_max_set = .true. if (present (gmlcode_bg)) graph_options%gmlcode_bg = gmlcode_bg if (present (gmlcode_fg)) graph_options%gmlcode_fg = gmlcode_fg end subroutine graph_options_set @ %def graph_options_set @ Write a simple account of all options. <>= public :: graph_options_write <>= subroutine graph_options_write (gro, unit) type(graph_options_t), intent(in) :: gro integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) 1 format (A,1x,'"',A,'"') 2 format (A,1x,L1) 3 format (A,1x,ES19.12) 4 format (A,1x,I0) 5 format (A,1x,'[undefined]') write (u, 1) "title =", char (gro%title) write (u, 1) "description =", char (gro%description) write (u, 1) "x_label =", char (gro%x_label) write (u, 1) "y_label =", char (gro%y_label) write (u, 2) "x_log =", gro%x_log write (u, 2) "y_log =", gro%y_log if (gro%x_min_set) then write (u, 3) "x_min =", gro%x_min else write (u, 5) "x_min =" end if if (gro%x_max_set) then write (u, 3) "x_max =", gro%x_max else write (u, 5) "x_max =" end if if (gro%y_min_set) then write (u, 3) "y_min =", gro%y_min else write (u, 5) "y_min =" end if if (gro%y_max_set) then write (u, 3) "y_max =", gro%y_max else write (u, 5) "y_max =" end if write (u, 4) "width_mm =", gro%width_mm write (u, 4) "height_mm =", gro%height_mm write (u, 1) "gmlcode_bg =", char (gro%gmlcode_bg) write (u, 1) "gmlcode_fg =", char (gro%gmlcode_fg) end subroutine graph_options_write @ %def graph_options_write @ Write a \LaTeX\ header/footer for the analysis file. <>= subroutine graph_options_write_tex_header (gro, unit) type(graph_options_t), intent(in) :: gro integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (gro%title /= "") then write (u, "(A)") write (u, "(A)") "\section{" // char (gro%title) // "}" else write (u, "(A)") "\section{" // char (quote_underscore (gro%id)) // "}" end if if (gro%description /= "") then write (u, "(A)") char (gro%description) write (u, *) write (u, "(A)") "\vspace*{\baselineskip}" end if write (u, "(A)") "\vspace*{\baselineskip}" write (u, "(A)") "\unitlength 1mm" write (u, "(A,I0,',',I0,A)") & "\begin{gmlgraph*}(", & gro%width_mm, gro%height_mm, & ")[dat]" end subroutine graph_options_write_tex_header subroutine graph_options_write_tex_footer (gro, unit) type(graph_options_t), intent(in) :: gro integer, intent(in), optional :: unit integer :: u, width, height width = gro%width_mm - 10 height = gro%height_mm - 10 u = given_output_unit (unit) write (u, "(A)") " begingmleps ""Whizard-Logo.eps"";" write (u, "(A,I0,A,I0,A)") & " base := (", width, "*unitlength,", height, "*unitlength);" write (u, "(A)") " height := 9.6*unitlength;" write (u, "(A)") " width := 11.2*unitlength;" write (u, "(A)") " endgmleps;" write (u, "(A)") "\end{gmlgraph*}" end subroutine graph_options_write_tex_footer @ %def graph_options_write_tex_header @ %def graph_options_write_tex_footer @ Return the analysis object ID. <>= function graph_options_get_id (gro) result (id) type(string_t) :: id type(graph_options_t), intent(in) :: gro id = gro%id end function graph_options_get_id @ %def graph_options_get_id @ Create an appropriate [[setup]] command (linear/log). <>= function graph_options_get_gml_setup (gro) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro type(string_t) :: x_str, y_str if (gro%x_log) then x_str = "log" else x_str = "linear" end if if (gro%y_log) then y_str = "log" else y_str = "linear" end if cmd = "setup (" // x_str // ", " // y_str // ");" end function graph_options_get_gml_setup @ %def graph_options_get_gml_setup @ Return the labels in GAMELAN form. <>= function graph_options_get_gml_x_label (gro) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro cmd = 'label.bot (<' // '<' // gro%x_label // '>' // '>, out);' end function graph_options_get_gml_x_label function graph_options_get_gml_y_label (gro) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro cmd = 'label.ulft (<' // '<' // gro%y_label // '>' // '>, out);' end function graph_options_get_gml_y_label @ %def graph_options_get_gml_x_label @ %def graph_options_get_gml_y_label @ Create an appropriate [[graphrange]] statement for the given graph options. Where the graph options are not set, use the supplied arguments, if any, otherwise set the undefined value. <>= function graph_options_get_gml_graphrange & (gro, x_min, x_max, y_min, y_max) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro real(default), intent(in), optional :: x_min, x_max, y_min, y_max type(string_t) :: x_min_str, x_max_str, y_min_str, y_max_str character(*), parameter :: fmt = "(ES15.8)" if (gro%x_min_set) then x_min_str = "#" // trim (adjustl (real2string (gro%x_min, fmt))) else if (present (x_min)) then x_min_str = "#" // trim (adjustl (real2string (x_min, fmt))) else x_min_str = "??" end if if (gro%x_max_set) then x_max_str = "#" // trim (adjustl (real2string (gro%x_max, fmt))) else if (present (x_max)) then x_max_str = "#" // trim (adjustl (real2string (x_max, fmt))) else x_max_str = "??" end if if (gro%y_min_set) then y_min_str = "#" // trim (adjustl (real2string (gro%y_min, fmt))) else if (present (y_min)) then y_min_str = "#" // trim (adjustl (real2string (y_min, fmt))) else y_min_str = "??" end if if (gro%y_max_set) then y_max_str = "#" // trim (adjustl (real2string (gro%y_max, fmt))) else if (present (y_max)) then y_max_str = "#" // trim (adjustl (real2string (y_max, fmt))) else y_max_str = "??" end if cmd = "graphrange (" // x_min_str // ", " // y_min_str // "), " & // "(" // x_max_str // ", " // y_max_str // ");" end function graph_options_get_gml_graphrange @ %def graph_options_get_gml_graphrange @ Get extra GAMELAN code to be executed before and after the usual drawing commands. <>= function graph_options_get_gml_bg_command (gro) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro cmd = gro%gmlcode_bg end function graph_options_get_gml_bg_command function graph_options_get_gml_fg_command (gro) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro cmd = gro%gmlcode_fg end function graph_options_get_gml_fg_command @ %def graph_options_get_gml_bg_command @ %def graph_options_get_gml_fg_command @ Append the header for generic data output in ifile format. We print only labels, not graphics parameters. <>= subroutine graph_options_get_header (pl, header, comment) type(graph_options_t), intent(in) :: pl type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment type(string_t) :: c if (present (comment)) then c = comment else c = "" end if call ifile_append (header, & c // "ID: " // pl%id) call ifile_append (header, & c // "title: " // pl%title) call ifile_append (header, & c // "description: " // pl%description) call ifile_append (header, & c // "x axis label: " // pl%x_label) call ifile_append (header, & c // "y axis label: " // pl%y_label) end subroutine graph_options_get_header @ %def graph_options_get_header @ \subsection{Drawing options} These options apply to an individual graph element (histogram or plot). <>= public :: drawing_options_t <>= type :: drawing_options_t type(string_t) :: dataset logical :: with_hbars = .false. logical :: with_base = .false. logical :: piecewise = .false. logical :: fill = .false. logical :: draw = .false. logical :: err = .false. logical :: symbols = .false. type(string_t) :: fill_options type(string_t) :: draw_options type(string_t) :: err_options type(string_t) :: symbol type(string_t) :: gmlcode_bg type(string_t) :: gmlcode_fg end type drawing_options_t @ %def drawing_options_t @ Write a simple account of all options. <>= public :: drawing_options_write <>= subroutine drawing_options_write (dro, unit) type(drawing_options_t), intent(in) :: dro integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) 1 format (A,1x,'"',A,'"') 2 format (A,1x,L1) write (u, 2) "with_hbars =", dro%with_hbars write (u, 2) "with_base =", dro%with_base write (u, 2) "piecewise =", dro%piecewise write (u, 2) "fill =", dro%fill write (u, 2) "draw =", dro%draw write (u, 2) "err =", dro%err write (u, 2) "symbols =", dro%symbols write (u, 1) "fill_options=", char (dro%fill_options) write (u, 1) "draw_options=", char (dro%draw_options) write (u, 1) "err_options =", char (dro%err_options) write (u, 1) "symbol =", char (dro%symbol) write (u, 1) "gmlcode_bg =", char (dro%gmlcode_bg) write (u, 1) "gmlcode_fg =", char (dro%gmlcode_fg) end subroutine drawing_options_write @ %def drawing_options_write @ Init with empty strings and default options, appropriate for either histogram or plot. <>= public :: drawing_options_init_histogram public :: drawing_options_init_plot <>= subroutine drawing_options_init_histogram (dro) type(drawing_options_t), intent(out) :: dro dro%dataset = "dat" dro%with_hbars = .true. dro%with_base = .true. dro%piecewise = .true. dro%fill = .true. dro%draw = .true. dro%fill_options = "withcolor col.default" dro%draw_options = "" dro%err_options = "" dro%symbol = "fshape(circle scaled 1mm)()" dro%gmlcode_bg = "" dro%gmlcode_fg = "" end subroutine drawing_options_init_histogram subroutine drawing_options_init_plot (dro) type(drawing_options_t), intent(out) :: dro dro%dataset = "dat" dro%draw = .true. dro%fill_options = "withcolor col.default" dro%draw_options = "" dro%err_options = "" dro%symbol = "fshape(circle scaled 1mm)()" dro%gmlcode_bg = "" dro%gmlcode_fg = "" end subroutine drawing_options_init_plot @ %def drawing_options_init_histogram @ %def drawing_options_init_plot @ Set individual options. <>= public :: drawing_options_set <>= subroutine drawing_options_set (dro, dataset, & with_hbars, with_base, piecewise, fill, draw, err, symbols, & fill_options, draw_options, err_options, symbol, & gmlcode_bg, gmlcode_fg) type(drawing_options_t), intent(inout) :: dro type(string_t), intent(in), optional :: dataset logical, intent(in), optional :: with_hbars, with_base, piecewise logical, intent(in), optional :: fill, draw, err, symbols type(string_t), intent(in), optional :: fill_options, draw_options type(string_t), intent(in), optional :: err_options, symbol type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg if (present (dataset)) dro%dataset = dataset if (present (with_hbars)) dro%with_hbars = with_hbars if (present (with_base)) dro%with_base = with_base if (present (piecewise)) dro%piecewise = piecewise if (present (fill)) dro%fill = fill if (present (draw)) dro%draw = draw if (present (err)) dro%err = err if (present (symbols)) dro%symbols = symbols if (present (fill_options)) dro%fill_options = fill_options if (present (draw_options)) dro%draw_options = draw_options if (present (err_options)) dro%err_options = err_options if (present (symbol)) dro%symbol = symbol if (present (gmlcode_bg)) dro%gmlcode_bg = gmlcode_bg if (present (gmlcode_fg)) dro%gmlcode_fg = gmlcode_fg end subroutine drawing_options_set @ %def drawing_options_set @ There are sepate commands for drawing the curve and for drawing errors. The symbols are applied to the latter. First of all, we may have to compute a baseline: <>= function drawing_options_get_calc_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro if (dro%with_base) then cmd = "calculate " // dro%dataset // ".base (" // dro%dataset // ") " & // "(x, #0);" else cmd = "" end if end function drawing_options_get_calc_command @ %def drawing_options_get_calc_command @ Return the drawing command. <>= function drawing_options_get_draw_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro if (dro%fill) then cmd = "fill" else if (dro%draw) then cmd = "draw" else cmd = "" end if if (dro%fill .or. dro%draw) then if (dro%piecewise) cmd = cmd // " piecewise" if (dro%draw .and. dro%with_base) cmd = cmd // " cyclic" cmd = cmd // " from (" // dro%dataset if (dro%with_base) then if (dro%piecewise) then cmd = cmd // ", " // dro%dataset // ".base/\" ! " else cmd = cmd // " ~ " // dro%dataset // ".base\" ! " end if end if cmd = cmd // ")" if (dro%fill) then cmd = cmd // " " // dro%fill_options if (dro%draw) cmd = cmd // " outlined" end if if (dro%draw) cmd = cmd // " " // dro%draw_options cmd = cmd // ";" end if end function drawing_options_get_draw_command @ %def drawing_options_get_draw_command @ The error command draws error bars, if any. <>= function drawing_options_get_err_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro if (dro%err) then cmd = "draw piecewise " & // "from (" // dro%dataset // ".err)" & // " " // dro%err_options // ";" else cmd = "" end if end function drawing_options_get_err_command @ %def drawing_options_get_err_command @ The symbol command draws symbols, if any. <>= function drawing_options_get_symb_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro if (dro%symbols) then cmd = "phantom" & // " from (" // dro%dataset // ")" & // " withsymbol (" // dro%symbol // ");" else cmd = "" end if end function drawing_options_get_symb_command @ %def drawing_options_get_symb_command @ Get extra GAMELAN code to be executed before and after the usual drawing commands. <>= function drawing_options_get_gml_bg_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro cmd = dro%gmlcode_bg end function drawing_options_get_gml_bg_command function drawing_options_get_gml_fg_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro cmd = dro%gmlcode_fg end function drawing_options_get_gml_fg_command @ %def drawing_options_get_gml_bg_command @ %def drawing_options_get_gml_fg_command @ \subsection{Observables} The observable type holds the accumulated observable values and weight sums which are necessary for proper averaging. <>= type :: observable_t private real(default) :: sum_values = 0 real(default) :: sum_squared_values = 0 real(default) :: sum_weights = 0 real(default) :: sum_squared_weights = 0 integer :: count = 0 type(string_t) :: obs_label type(string_t) :: obs_unit type(graph_options_t) :: graph_options end type observable_t @ %def observable_t @ Initialize with defined properties <>= subroutine observable_init (obs, obs_label, obs_unit, graph_options) type(observable_t), intent(out) :: obs type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options if (present (obs_label)) then obs%obs_label = obs_label else obs%obs_label = "" end if if (present (obs_unit)) then obs%obs_unit = obs_unit else obs%obs_unit = "" end if if (present (graph_options)) then obs%graph_options = graph_options else call graph_options_init (obs%graph_options) end if end subroutine observable_init @ %def observable_init @ Reset all numeric entries. <>= subroutine observable_clear (obs) type(observable_t), intent(inout) :: obs obs%sum_values = 0 obs%sum_squared_values = 0 obs%sum_weights = 0 obs%sum_squared_weights = 0 obs%count = 0 end subroutine observable_clear @ %def observable_clear @ Record a value. Always successful for observables. <>= interface observable_record_value module procedure observable_record_value_unweighted module procedure observable_record_value_weighted end interface <>= subroutine observable_record_value_unweighted (obs, value, success) type(observable_t), intent(inout) :: obs real(default), intent(in) :: value logical, intent(out), optional :: success obs%sum_values = obs%sum_values + value obs%sum_squared_values = obs%sum_squared_values + value**2 obs%sum_weights = obs%sum_weights + 1 obs%sum_squared_weights = obs%sum_squared_weights + 1 obs%count = obs%count + 1 if (present (success)) success = .true. end subroutine observable_record_value_unweighted subroutine observable_record_value_weighted (obs, value, weight, success) type(observable_t), intent(inout) :: obs real(default), intent(in) :: value, weight logical, intent(out), optional :: success obs%sum_values = obs%sum_values + value * weight obs%sum_squared_values = obs%sum_squared_values + value**2 * weight obs%sum_weights = obs%sum_weights + weight obs%sum_squared_weights = obs%sum_squared_weights + weight**2 obs%count = obs%count + 1 if (present (success)) success = .true. end subroutine observable_record_value_weighted @ %def observable_record_value @ Here are the statistics formulas: \begin{enumerate} \item Unweighted case: Given a sample of $n$ values $x_i$, the average is \begin{equation} \langle x \rangle = \frac{\sum x_i}{n} \end{equation} and the error estimate \begin{align} \Delta x &= \sqrt{\frac{1}{n-1}\langle{\sum(x_i - \langle x\rangle)^2}} \\ &= \sqrt{\frac{1}{n-1} \left(\frac{\sum x_i^2}{n} - \frac{(\sum x_i)^2}{n^2}\right)} \end{align} \item Weighted case: Instead of weight 1, each event comes with weight $w_i$. \begin{equation} \langle x \rangle = \frac{\sum x_i w_i}{\sum w_i} \end{equation} and \begin{equation} \Delta x = \sqrt{\frac{1}{n-1} \left(\frac{\sum x_i^2 w_i}{\sum w_i} - \frac{(\sum x_i w_i)^2}{(\sum w_i)^2}\right)} \end{equation} For $w_i=1$, this specializes to the previous formula. \end{enumerate} <>= function observable_get_n_entries (obs) result (n) integer :: n type(observable_t), intent(in) :: obs n = obs%count end function observable_get_n_entries function observable_get_average (obs) result (avg) real(default) :: avg type(observable_t), intent(in) :: obs if (obs%sum_weights /= 0) then avg = obs%sum_values / obs%sum_weights else avg = 0 end if end function observable_get_average function observable_get_error (obs) result (err) real(default) :: err type(observable_t), intent(in) :: obs real(default) :: var, n if (obs%sum_weights /= 0) then select case (obs%count) case (0:1) err = 0 case default n = obs%count var = obs%sum_squared_values / obs%sum_weights & - (obs%sum_values / obs%sum_weights) ** 2 err = sqrt (max (var, 0._default) / (n - 1)) end select else err = 0 end if end function observable_get_error @ %def observable_get_n_entries @ %def observable_get_sum @ %def observable_get_average @ %def observable_get_error @ Write label and/or physical unit to a string. <>= function observable_get_label (obs, wl, wu) result (string) type(string_t) :: string type(observable_t), intent(in) :: obs logical, intent(in) :: wl, wu type(string_t) :: obs_label, obs_unit if (wl) then if (obs%obs_label /= "") then obs_label = obs%obs_label else obs_label = "\textrm{Observable}" end if else obs_label = "" end if if (wu) then if (obs%obs_unit /= "") then if (wl) then obs_unit = "\;[" // obs%obs_unit // "]" else obs_unit = obs%obs_unit end if else obs_unit = "" end if else obs_unit = "" end if string = obs_label // obs_unit end function observable_get_label @ %def observable_get_label @ \subsection{Output} <>= subroutine observable_write (obs, unit) type(observable_t), intent(in) :: obs integer, intent(in), optional :: unit real(default) :: avg, err, relerr integer :: n integer :: u u = given_output_unit (unit); if (u < 0) return avg = observable_get_average (obs) err = observable_get_error (obs) if (avg /= 0) then relerr = err / abs (avg) else relerr = 0 end if n = observable_get_n_entries (obs) if (obs%graph_options%title /= "") then write (u, "(A,1x,3A)") & "title =", '"', char (obs%graph_options%title), '"' end if if (obs%graph_options%title /= "") then write (u, "(A,1x,3A)") & "description =", '"', char (obs%graph_options%description), '"' end if write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")", advance = "no") & "average =", avg call write_unit () write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")", advance = "no") & "error[abs] =", err call write_unit () write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")") & "error[rel] =", relerr write (u, "(A,1x,I0)") & "n_entries =", n contains subroutine write_unit () if (obs%obs_unit /= "") then write (u, "(1x,A)") char (obs%obs_unit) else write (u, *) end if end subroutine write_unit end subroutine observable_write @ %def observable_write @ \LaTeX\ output. <>= subroutine observable_write_driver (obs, unit, write_heading) type(observable_t), intent(in) :: obs integer, intent(in), optional :: unit logical, intent(in), optional :: write_heading real(default) :: avg, err integer :: n_digits logical :: heading integer :: u u = given_output_unit (unit); if (u < 0) return heading = .true.; if (present (write_heading)) heading = write_heading avg = observable_get_average (obs) err = observable_get_error (obs) if (avg /= 0 .and. err /= 0) then n_digits = max (2, 2 - int (log10 (abs (err / real (avg, default))))) else if (avg /= 0) then n_digits = 100 else n_digits = 1 end if if (heading) then write (u, "(A)") if (obs%graph_options%title /= "") then write (u, "(A)") "\section{" // char (obs%graph_options%title) & // "}" else write (u, "(A)") "\section{Observable}" end if if (obs%graph_options%description /= "") then write (u, "(A)") char (obs%graph_options%description) write (u, *) end if write (u, "(A)") "\begin{flushleft}" end if write (u, "(A)", advance="no") " $\langle{" ! $ sign write (u, "(A)", advance="no") char (observable_get_label (obs, wl=.true., wu=.false.)) write (u, "(A)", advance="no") "}\rangle = " write (u, "(A)", advance="no") char (tex_format (avg, n_digits)) write (u, "(A)", advance="no") "\pm" write (u, "(A)", advance="no") char (tex_format (err, 2)) write (u, "(A)", advance="no") "\;{" write (u, "(A)", advance="no") char (observable_get_label (obs, wl=.false., wu=.true.)) write (u, "(A)") "}" write (u, "(A)", advance="no") " \quad[n_{\text{entries}} = " write (u, "(I0)",advance="no") observable_get_n_entries (obs) write (u, "(A)") "]$" ! $ fool Emacs' noweb mode if (heading) then write (u, "(A)") "\end{flushleft}" end if end subroutine observable_write_driver @ %def observable_write_driver @ \subsection{Histograms} \subsubsection{Bins} <>= type :: bin_t private real(default) :: midpoint = 0 real(default) :: width = 0 real(default) :: sum_weights = 0 real(default) :: sum_squared_weights = 0 real(default) :: sum_excess_weights = 0 integer :: count = 0 end type bin_t @ %def bin_t <>= subroutine bin_init (bin, midpoint, width) type(bin_t), intent(out) :: bin real(default), intent(in) :: midpoint, width bin%midpoint = midpoint bin%width = width end subroutine bin_init @ %def bin_init <>= elemental subroutine bin_clear (bin) type(bin_t), intent(inout) :: bin bin%sum_weights = 0 bin%sum_squared_weights = 0 bin%sum_excess_weights = 0 bin%count = 0 end subroutine bin_clear @ %def bin_clear <>= subroutine bin_record_value (bin, normalize, weight, excess) type(bin_t), intent(inout) :: bin logical, intent(in) :: normalize real(default), intent(in) :: weight real(default), intent(in), optional :: excess real(default) :: w, e if (normalize) then if (bin%width /= 0) then w = weight / bin%width if (present (excess)) e = excess / bin%width else w = 0 if (present (excess)) e = 0 end if else w = weight if (present (excess)) e = excess end if bin%sum_weights = bin%sum_weights + w bin%sum_squared_weights = bin%sum_squared_weights + w ** 2 if (present (excess)) & bin%sum_excess_weights = bin%sum_excess_weights + abs (e) bin%count = bin%count + 1 end subroutine bin_record_value @ %def bin_record_value <>= function bin_get_midpoint (bin) result (x) real(default) :: x type(bin_t), intent(in) :: bin x = bin%midpoint end function bin_get_midpoint function bin_get_width (bin) result (w) real(default) :: w type(bin_t), intent(in) :: bin w = bin%width end function bin_get_width function bin_get_n_entries (bin) result (n) integer :: n type(bin_t), intent(in) :: bin n = bin%count end function bin_get_n_entries function bin_get_sum (bin) result (s) real(default) :: s type(bin_t), intent(in) :: bin s = bin%sum_weights end function bin_get_sum function bin_get_error (bin) result (err) real(default) :: err type(bin_t), intent(in) :: bin err = sqrt (bin%sum_squared_weights) end function bin_get_error function bin_get_excess (bin) result (excess) real(default) :: excess type(bin_t), intent(in) :: bin excess = bin%sum_excess_weights end function bin_get_excess @ %def bin_get_midpoint @ %def bin_get_width @ %def bin_get_n_entries @ %def bin_get_sum @ %def bin_get_error @ %def bin_get_excess <>= subroutine bin_write_header (unit) integer, intent(in), optional :: unit character(120) :: buffer integer :: u u = given_output_unit (unit); if (u < 0) return write (buffer, "(A,4(1x," //HISTOGRAM_HEAD_FORMAT // "),2x,A)") & "#", "bin midpoint", "value ", "error ", & "excess ", "n" write (u, "(A)") trim (buffer) end subroutine bin_write_header subroutine bin_write (bin, unit) type(bin_t), intent(in) :: bin integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,4(1x," // HISTOGRAM_DATA_FORMAT // "),2x,I0)") & bin_get_midpoint (bin), & bin_get_sum (bin), & bin_get_error (bin), & bin_get_excess (bin), & bin_get_n_entries (bin) end subroutine bin_write @ %def bin_write_header @ %def bin_write @ \subsubsection{Histograms} <>= type :: histogram_t private real(default) :: lower_bound = 0 real(default) :: upper_bound = 0 real(default) :: width = 0 integer :: n_bins = 0 logical :: normalize_bins = .false. type(observable_t) :: obs type(observable_t) :: obs_within_bounds type(bin_t) :: underflow type(bin_t), dimension(:), allocatable :: bin type(bin_t) :: overflow type(graph_options_t) :: graph_options type(drawing_options_t) :: drawing_options end type histogram_t @ %def histogram_t @ \subsubsection{Initializer/finalizer} Initialize a histogram. We may provide either the bin width or the number of bins. A finalizer is not needed, since the histogram contains no pointer (sub)components. <>= interface histogram_init module procedure histogram_init_n_bins module procedure histogram_init_bin_width end interface <>= subroutine histogram_init_n_bins (h, id, & lower_bound, upper_bound, n_bins, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(histogram_t), intent(out) :: h type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound integer, intent(in) :: n_bins logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options real(default) :: bin_width integer :: i call observable_init (h%obs_within_bounds, obs_label, obs_unit) call observable_init (h%obs, obs_label, obs_unit) h%lower_bound = lower_bound h%upper_bound = upper_bound h%n_bins = max (n_bins, 1) h%width = h%upper_bound - h%lower_bound h%normalize_bins = normalize_bins bin_width = h%width / h%n_bins allocate (h%bin (h%n_bins)) call bin_init (h%underflow, h%lower_bound, 0._default) do i = 1, h%n_bins call bin_init (h%bin(i), & h%lower_bound - bin_width/2 + i * bin_width, bin_width) end do call bin_init (h%overflow, h%upper_bound, 0._default) if (present (graph_options)) then h%graph_options = graph_options else call graph_options_init (h%graph_options) end if call graph_options_set (h%graph_options, id = id) if (present (drawing_options)) then h%drawing_options = drawing_options else call drawing_options_init_histogram (h%drawing_options) end if end subroutine histogram_init_n_bins subroutine histogram_init_bin_width (h, id, & lower_bound, upper_bound, bin_width, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(histogram_t), intent(out) :: h type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound, bin_width logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options integer :: n_bins if (bin_width /= 0) then n_bins = nint ((upper_bound - lower_bound) / bin_width) else n_bins = 1 end if call histogram_init_n_bins (h, id, & lower_bound, upper_bound, n_bins, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) end subroutine histogram_init_bin_width @ %def histogram_init @ Initialize a histogram by copying another one. Since [[h]] has no pointer (sub)components, intrinsic assignment is sufficient. Optionally, we replace the drawing options. <>= subroutine histogram_init_histogram (h, h_in, drawing_options) type(histogram_t), intent(out) :: h type(histogram_t), intent(in) :: h_in type(drawing_options_t), intent(in), optional :: drawing_options h = h_in if (present (drawing_options)) then h%drawing_options = drawing_options end if end subroutine histogram_init_histogram @ %def histogram_init_histogram @ \subsubsection{Fill histograms} Clear the histogram contents, but do not modify the structure. <>= subroutine histogram_clear (h) type(histogram_t), intent(inout) :: h call observable_clear (h%obs) call observable_clear (h%obs_within_bounds) call bin_clear (h%underflow) if (allocated (h%bin)) call bin_clear (h%bin) call bin_clear (h%overflow) end subroutine histogram_clear @ %def histogram_clear @ Record a value. Successful if the value is within bounds, otherwise it is recorded as under-/overflow. Optionally, we may provide an excess weight that could be returned by the unweighting procedure. <>= subroutine histogram_record_value_unweighted (h, value, excess, success) type(histogram_t), intent(inout) :: h real(default), intent(in) :: value real(default), intent(in), optional :: excess logical, intent(out), optional :: success integer :: i_bin call observable_record_value (h%obs, value) if (h%width /= 0) then i_bin = floor (((value - h%lower_bound) / h%width) * h%n_bins) + 1 else i_bin = 0 end if if (i_bin <= 0) then call bin_record_value (h%underflow, .false., 1._default, excess) if (present (success)) success = .false. else if (i_bin <= h%n_bins) then call observable_record_value (h%obs_within_bounds, value) call bin_record_value & (h%bin(i_bin), h%normalize_bins, 1._default, excess) if (present (success)) success = .true. else call bin_record_value (h%overflow, .false., 1._default, excess) if (present (success)) success = .false. end if end subroutine histogram_record_value_unweighted @ %def histogram_record_value_unweighted @ Weighted events: analogous, but no excess weight. <>= subroutine histogram_record_value_weighted (h, value, weight, success) type(histogram_t), intent(inout) :: h real(default), intent(in) :: value, weight logical, intent(out), optional :: success integer :: i_bin call observable_record_value (h%obs, value, weight) if (h%width /= 0) then i_bin = floor (((value - h%lower_bound) / h%width) * h%n_bins) + 1 else i_bin = 0 end if if (i_bin <= 0) then call bin_record_value (h%underflow, .false., weight) if (present (success)) success = .false. else if (i_bin <= h%n_bins) then call observable_record_value (h%obs_within_bounds, value, weight) call bin_record_value (h%bin(i_bin), h%normalize_bins, weight) if (present (success)) success = .true. else call bin_record_value (h%overflow, .false., weight) if (present (success)) success = .false. end if end subroutine histogram_record_value_weighted @ %def histogram_record_value_weighted @ \subsubsection{Access contents} Inherited from the observable component (all-over average etc.) <>= function histogram_get_n_entries (h) result (n) integer :: n type(histogram_t), intent(in) :: h n = observable_get_n_entries (h%obs) end function histogram_get_n_entries function histogram_get_average (h) result (avg) real(default) :: avg type(histogram_t), intent(in) :: h avg = observable_get_average (h%obs) end function histogram_get_average function histogram_get_error (h) result (err) real(default) :: err type(histogram_t), intent(in) :: h err = observable_get_error (h%obs) end function histogram_get_error @ %def histogram_get_n_entries @ %def histogram_get_average @ %def histogram_get_error @ Analogous, but applied only to events within bounds. <>= function histogram_get_n_entries_within_bounds (h) result (n) integer :: n type(histogram_t), intent(in) :: h n = observable_get_n_entries (h%obs_within_bounds) end function histogram_get_n_entries_within_bounds function histogram_get_average_within_bounds (h) result (avg) real(default) :: avg type(histogram_t), intent(in) :: h avg = observable_get_average (h%obs_within_bounds) end function histogram_get_average_within_bounds function histogram_get_error_within_bounds (h) result (err) real(default) :: err type(histogram_t), intent(in) :: h err = observable_get_error (h%obs_within_bounds) end function histogram_get_error_within_bounds @ %def histogram_get_n_entries_within_bounds @ %def histogram_get_average_within_bounds @ %def histogram_get_error_within_bounds Get the number of bins <>= function histogram_get_n_bins (h) result (n) type(histogram_t), intent(in) :: h integer :: n n = h%n_bins end function histogram_get_n_bins @ %def histogram_get_n_bins @ Check bins. If the index is zero or above the limit, return the results for underflow or overflow, respectively. <>= function histogram_get_n_entries_for_bin (h, i) result (n) integer :: n type(histogram_t), intent(in) :: h integer, intent(in) :: i if (i <= 0) then n = bin_get_n_entries (h%underflow) else if (i <= h%n_bins) then n = bin_get_n_entries (h%bin(i)) else n = bin_get_n_entries (h%overflow) end if end function histogram_get_n_entries_for_bin function histogram_get_sum_for_bin (h, i) result (avg) real(default) :: avg type(histogram_t), intent(in) :: h integer, intent(in) :: i if (i <= 0) then avg = bin_get_sum (h%underflow) else if (i <= h%n_bins) then avg = bin_get_sum (h%bin(i)) else avg = bin_get_sum (h%overflow) end if end function histogram_get_sum_for_bin function histogram_get_error_for_bin (h, i) result (err) real(default) :: err type(histogram_t), intent(in) :: h integer, intent(in) :: i if (i <= 0) then err = bin_get_error (h%underflow) else if (i <= h%n_bins) then err = bin_get_error (h%bin(i)) else err = bin_get_error (h%overflow) end if end function histogram_get_error_for_bin function histogram_get_excess_for_bin (h, i) result (err) real(default) :: err type(histogram_t), intent(in) :: h integer, intent(in) :: i if (i <= 0) then err = bin_get_excess (h%underflow) else if (i <= h%n_bins) then err = bin_get_excess (h%bin(i)) else err = bin_get_excess (h%overflow) end if end function histogram_get_excess_for_bin @ %def histogram_get_n_entries_for_bin @ %def histogram_get_sum_for_bin @ %def histogram_get_error_for_bin @ %def histogram_get_excess_for_bin @ Return a pointer to the graph options. <>= function histogram_get_graph_options_ptr (h) result (ptr) type(graph_options_t), pointer :: ptr type(histogram_t), intent(in), target :: h ptr => h%graph_options end function histogram_get_graph_options_ptr @ %def histogram_get_graph_options_ptr @ Return a pointer to the drawing options. <>= function histogram_get_drawing_options_ptr (h) result (ptr) type(drawing_options_t), pointer :: ptr type(histogram_t), intent(in), target :: h ptr => h%drawing_options end function histogram_get_drawing_options_ptr @ %def histogram_get_drawing_options_ptr @ \subsubsection{Output} <>= subroutine histogram_write (h, unit) type(histogram_t), intent(in) :: h integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return call bin_write_header (u) if (allocated (h%bin)) then do i = 1, h%n_bins call bin_write (h%bin(i), u) end do end if write (u, "(A)") write (u, "(A,1x,A)") "#", "Underflow:" call bin_write (h%underflow, u) write (u, "(A)") write (u, "(A,1x,A)") "#", "Overflow:" call bin_write (h%overflow, u) write (u, "(A)") write (u, "(A,1x,A)") "#", "Summary: data within bounds" call observable_write (h%obs_within_bounds, u) write (u, "(A)") write (u, "(A,1x,A)") "#", "Summary: all data" call observable_write (h%obs, u) write (u, "(A)") end subroutine histogram_write @ %def histogram_write @ Write the GAMELAN reader for histogram contents. <>= subroutine histogram_write_gml_reader (h, filename, unit) type(histogram_t), intent(in) :: h type(string_t), intent(in) :: filename integer, intent(in), optional :: unit character(*), parameter :: fmt = "(ES15.8)" integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(2x,A)") 'fromfile "' // char (filename) // '":' write (u, "(4x,A)") 'key "# Histogram:";' write (u, "(4x,A)") 'dx := #' & // real2char (h%width / h%n_bins / 2, fmt) // ';' write (u, "(4x,A)") 'for i withinblock:' write (u, "(6x,A)") 'get x, y, y.d, y.n, y.e;' if (h%drawing_options%with_hbars) then write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) & // ') (x,y) hbar dx;' else write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) & // ') (x,y);' end if if (h%drawing_options%err) then write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) & // '.err) ' & // '(x,y) vbar y.d;' end if !!! Future excess options for plots ! write (u, "(6x,A)") 'if show_excess: ' // & ! & 'plot(dat.e)(x, y plus y.e) hbar dx; fi' write (u, "(4x,A)") 'endfor' write (u, "(2x,A)") 'endfrom' end subroutine histogram_write_gml_reader @ %def histogram_write_gml_reader @ \LaTeX\ and GAMELAN output. <>= subroutine histogram_write_gml_driver (h, filename, unit) type(histogram_t), intent(in) :: h type(string_t), intent(in) :: filename integer, intent(in), optional :: unit type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd integer :: u u = given_output_unit (unit); if (u < 0) return call graph_options_write_tex_header (h%graph_options, unit) write (u, "(2x,A)") char (graph_options_get_gml_setup (h%graph_options)) write (u, "(2x,A)") char (graph_options_get_gml_graphrange & (h%graph_options, x_min=h%lower_bound, x_max=h%upper_bound)) call histogram_write_gml_reader (h, filename, unit) calc_cmd = drawing_options_get_calc_command (h%drawing_options) if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd) bg_cmd = drawing_options_get_gml_bg_command (h%drawing_options) if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd) draw_cmd = drawing_options_get_draw_command (h%drawing_options) if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd) err_cmd = drawing_options_get_err_command (h%drawing_options) if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd) symb_cmd = drawing_options_get_symb_command (h%drawing_options) if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd) fg_cmd = drawing_options_get_gml_fg_command (h%drawing_options) if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd) write (u, "(2x,A)") char (graph_options_get_gml_x_label (h%graph_options)) write (u, "(2x,A)") char (graph_options_get_gml_y_label (h%graph_options)) call graph_options_write_tex_footer (h%graph_options, unit) write (u, "(A)") "\vspace*{2\baselineskip}" write (u, "(A)") "\begin{flushleft}" write (u, "(A)") "\textbf{Data within bounds:} \\" call observable_write_driver (h%obs_within_bounds, unit, & write_heading=.false.) write (u, "(A)") "\\[0.5\baselineskip]" write (u, "(A)") "\textbf{All data:} \\" call observable_write_driver (h%obs, unit, write_heading=.false.) write (u, "(A)") "\end{flushleft}" end subroutine histogram_write_gml_driver @ %def histogram_write_gml_driver @ Return the header for generic data output as an ifile. <>= subroutine histogram_get_header (h, header, comment) type(histogram_t), intent(in) :: h type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment type(string_t) :: c if (present (comment)) then c = comment else c = "" end if call ifile_append (header, c // "WHIZARD histogram data") call graph_options_get_header (h%graph_options, header, comment) call ifile_append (header, & c // "range: " // real2string (h%lower_bound) & // " - " // real2string (h%upper_bound)) call ifile_append (header, & c // "counts total: " & // int2char (histogram_get_n_entries_within_bounds (h))) call ifile_append (header, & c // "total average: " & // real2string (histogram_get_average_within_bounds (h)) // " +- " & // real2string (histogram_get_error_within_bounds (h))) end subroutine histogram_get_header @ %def histogram_get_header @ \subsection{Plots} \subsubsection{Points} <>= type :: point_t private real(default) :: x = 0 real(default) :: y = 0 real(default) :: yerr = 0 real(default) :: xerr = 0 type(point_t), pointer :: next => null () end type point_t @ %def point_t <>= interface point_init module procedure point_init_contents module procedure point_init_point end interface <>= subroutine point_init_contents (point, x, y, yerr, xerr) type(point_t), intent(out) :: point real(default), intent(in) :: x, y real(default), intent(in), optional :: yerr, xerr point%x = x point%y = y if (present (yerr)) point%yerr = yerr if (present (xerr)) point%xerr = xerr end subroutine point_init_contents subroutine point_init_point (point, point_in) type(point_t), intent(out) :: point type(point_t), intent(in) :: point_in point%x = point_in%x point%y = point_in%y point%yerr = point_in%yerr point%xerr = point_in%xerr end subroutine point_init_point @ %def point_init <>= function point_get_x (point) result (x) real(default) :: x type(point_t), intent(in) :: point x = point%x end function point_get_x function point_get_y (point) result (y) real(default) :: y type(point_t), intent(in) :: point y = point%y end function point_get_y function point_get_xerr (point) result (xerr) real(default) :: xerr type(point_t), intent(in) :: point xerr = point%xerr end function point_get_xerr function point_get_yerr (point) result (yerr) real(default) :: yerr type(point_t), intent(in) :: point yerr = point%yerr end function point_get_yerr @ %def point_get_x @ %def point_get_y @ %def point_get_xerr @ %def point_get_yerr <>= subroutine point_write_header (unit) integer, intent(in) :: unit character(120) :: buffer integer :: u u = given_output_unit (unit); if (u < 0) return write (buffer, "(A,4(1x," // HISTOGRAM_HEAD_FORMAT // "))") & "#", "x ", "y ", "yerr ", "xerr " write (u, "(A)") trim (buffer) end subroutine point_write_header subroutine point_write (point, unit) type(point_t), intent(in) :: point integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,4(1x," // HISTOGRAM_DATA_FORMAT // "))") & point_get_x (point), & point_get_y (point), & point_get_yerr (point), & point_get_xerr (point) end subroutine point_write @ %def point_write @ \subsubsection{Plots} <>= type :: plot_t private type(point_t), pointer :: first => null () type(point_t), pointer :: last => null () integer :: count = 0 type(graph_options_t) :: graph_options type(drawing_options_t) :: drawing_options end type plot_t @ %def plot_t @ \subsubsection{Initializer/finalizer} Initialize a plot. We provide the lower and upper bound in the $x$ direction. <>= interface plot_init module procedure plot_init_empty module procedure plot_init_plot end interface <>= subroutine plot_init_empty (p, id, graph_options, drawing_options) type(plot_t), intent(out) :: p type(string_t), intent(in) :: id type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options if (present (graph_options)) then p%graph_options = graph_options else call graph_options_init (p%graph_options) end if call graph_options_set (p%graph_options, id = id) if (present (drawing_options)) then p%drawing_options = drawing_options else call drawing_options_init_plot (p%drawing_options) end if end subroutine plot_init_empty @ %def plot_init @ Initialize a plot by copying another one, optionally merging in a new set of drawing options. Since [[p]] has pointer (sub)components, we have to explicitly deep-copy the original. <>= subroutine plot_init_plot (p, p_in, drawing_options) type(plot_t), intent(out) :: p type(plot_t), intent(in) :: p_in type(drawing_options_t), intent(in), optional :: drawing_options type(point_t), pointer :: current, new current => p_in%first do while (associated (current)) allocate (new) call point_init (new, current) if (associated (p%last)) then p%last%next => new else p%first => new end if p%last => new current => current%next end do p%count = p_in%count p%graph_options = p_in%graph_options if (present (drawing_options)) then p%drawing_options = drawing_options else p%drawing_options = p_in%drawing_options end if end subroutine plot_init_plot @ %def plot_init_plot @ Finalize the plot by deallocating the list of points. <>= subroutine plot_final (plot) type(plot_t), intent(inout) :: plot type(point_t), pointer :: current do while (associated (plot%first)) current => plot%first plot%first => current%next deallocate (current) end do plot%last => null () end subroutine plot_final @ %def plot_final @ \subsubsection{Fill plots} Clear the plot contents, but do not modify the structure. <>= subroutine plot_clear (plot) type(plot_t), intent(inout) :: plot plot%count = 0 call plot_final (plot) end subroutine plot_clear @ %def plot_clear @ Record a value. Successful if the value is within bounds, otherwise it is recorded as under-/overflow. <>= subroutine plot_record_value (plot, x, y, yerr, xerr, success) type(plot_t), intent(inout) :: plot real(default), intent(in) :: x, y real(default), intent(in), optional :: yerr, xerr logical, intent(out), optional :: success type(point_t), pointer :: point plot%count = plot%count + 1 allocate (point) call point_init (point, x, y, yerr, xerr) if (associated (plot%first)) then plot%last%next => point else plot%first => point end if plot%last => point if (present (success)) success = .true. end subroutine plot_record_value @ %def plot_record_value @ \subsubsection{Access contents} The number of points. <>= function plot_get_n_entries (plot) result (n) integer :: n type(plot_t), intent(in) :: plot n = plot%count end function plot_get_n_entries @ %def plot_get_n_entries @ Return a pointer to the graph options. <>= function plot_get_graph_options_ptr (p) result (ptr) type(graph_options_t), pointer :: ptr type(plot_t), intent(in), target :: p ptr => p%graph_options end function plot_get_graph_options_ptr @ %def plot_get_graph_options_ptr @ Return a pointer to the drawing options. <>= function plot_get_drawing_options_ptr (p) result (ptr) type(drawing_options_t), pointer :: ptr type(plot_t), intent(in), target :: p ptr => p%drawing_options end function plot_get_drawing_options_ptr @ %def plot_get_drawing_options_ptr @ \subsubsection{Output} This output format is used by the GAMELAN driver below. <>= subroutine plot_write (plot, unit) type(plot_t), intent(in) :: plot integer, intent(in), optional :: unit type(point_t), pointer :: point integer :: u u = given_output_unit (unit); if (u < 0) return call point_write_header (u) point => plot%first do while (associated (point)) call point_write (point, unit) point => point%next end do write (u, *) write (u, "(A,1x,A)") "#", "Summary:" write (u, "(A,1x,I0)") & "n_entries =", plot_get_n_entries (plot) write (u, *) end subroutine plot_write @ %def plot_write @ Write the GAMELAN reader for plot contents. <>= subroutine plot_write_gml_reader (p, filename, unit) type(plot_t), intent(in) :: p type(string_t), intent(in) :: filename integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(2x,A)") 'fromfile "' // char (filename) // '":' write (u, "(4x,A)") 'key "# Plot:";' write (u, "(4x,A)") 'for i withinblock:' write (u, "(6x,A)") 'get x, y, y.err, x.err;' write (u, "(6x,A)") 'plot (' // char (p%drawing_options%dataset) & // ') (x,y);' if (p%drawing_options%err) then write (u, "(6x,A)") 'plot (' // char (p%drawing_options%dataset) & // '.err) (x,y) vbar y.err hbar x.err;' end if write (u, "(4x,A)") 'endfor' write (u, "(2x,A)") 'endfrom' end subroutine plot_write_gml_reader @ %def plot_write_gml_header @ \LaTeX\ and GAMELAN output. Analogous to histogram output. <>= subroutine plot_write_gml_driver (p, filename, unit) type(plot_t), intent(in) :: p type(string_t), intent(in) :: filename integer, intent(in), optional :: unit type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd integer :: u u = given_output_unit (unit); if (u < 0) return call graph_options_write_tex_header (p%graph_options, unit) write (u, "(2x,A)") & char (graph_options_get_gml_setup (p%graph_options)) write (u, "(2x,A)") & char (graph_options_get_gml_graphrange (p%graph_options)) call plot_write_gml_reader (p, filename, unit) calc_cmd = drawing_options_get_calc_command (p%drawing_options) if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd) bg_cmd = drawing_options_get_gml_bg_command (p%drawing_options) if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd) draw_cmd = drawing_options_get_draw_command (p%drawing_options) if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd) err_cmd = drawing_options_get_err_command (p%drawing_options) if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd) symb_cmd = drawing_options_get_symb_command (p%drawing_options) if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd) fg_cmd = drawing_options_get_gml_fg_command (p%drawing_options) if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd) write (u, "(2x,A)") char (graph_options_get_gml_x_label (p%graph_options)) write (u, "(2x,A)") char (graph_options_get_gml_y_label (p%graph_options)) call graph_options_write_tex_footer (p%graph_options, unit) end subroutine plot_write_gml_driver @ %def plot_write_driver @ Append header for generic data output in ifile format. <>= subroutine plot_get_header (plot, header, comment) type(plot_t), intent(in) :: plot type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment type(string_t) :: c if (present (comment)) then c = comment else c = "" end if call ifile_append (header, c // "WHIZARD plot data") call graph_options_get_header (plot%graph_options, header, comment) call ifile_append (header, & c // "number of points: " & // int2char (plot_get_n_entries (plot))) end subroutine plot_get_header @ %def plot_get_header @ \subsection{Graphs} A graph is a container for several graph elements. Each graph element is either a plot or a histogram. There is an appropriate base type below (the [[analysis_object_t]]), but to avoid recursion, we define a separate base type here. Note that there is no actual recursion: a graph is an analysis object, but a graph cannot contain graphs. (If we could use type extension, the implementation would be much more transparent.) \subsubsection{Graph elements} Graph elements cannot be filled by the [[record]] command directly. The contents are always copied from elementary histograms or plots. <>= type :: graph_element_t private integer :: type = AN_UNDEFINED type(histogram_t), pointer :: h => null () type(plot_t), pointer :: p => null () end type graph_element_t @ %def graph_element_t <>= subroutine graph_element_final (el) type(graph_element_t), intent(inout) :: el select case (el%type) case (AN_HISTOGRAM) deallocate (el%h) case (AN_PLOT) call plot_final (el%p) deallocate (el%p) end select el%type = AN_UNDEFINED end subroutine graph_element_final @ %def graph_element_final @ Return the number of entries in the graph element: <>= function graph_element_get_n_entries (el) result (n) integer :: n type(graph_element_t), intent(in) :: el select case (el%type) case (AN_HISTOGRAM); n = histogram_get_n_entries (el%h) case (AN_PLOT); n = plot_get_n_entries (el%p) case default; n = 0 end select end function graph_element_get_n_entries @ %def graph_element_get_n_entries @ Return a pointer to the graph / drawing options. <>= function graph_element_get_graph_options_ptr (el) result (ptr) type(graph_options_t), pointer :: ptr type(graph_element_t), intent(in) :: el select case (el%type) case (AN_HISTOGRAM); ptr => histogram_get_graph_options_ptr (el%h) case (AN_PLOT); ptr => plot_get_graph_options_ptr (el%p) case default; ptr => null () end select end function graph_element_get_graph_options_ptr function graph_element_get_drawing_options_ptr (el) result (ptr) type(drawing_options_t), pointer :: ptr type(graph_element_t), intent(in) :: el select case (el%type) case (AN_HISTOGRAM); ptr => histogram_get_drawing_options_ptr (el%h) case (AN_PLOT); ptr => plot_get_drawing_options_ptr (el%p) case default; ptr => null () end select end function graph_element_get_drawing_options_ptr @ %def graph_element_get_graph_options_ptr @ %def graph_element_get_drawing_options_ptr @ Output, simple wrapper for the plot/histogram writer. <>= subroutine graph_element_write (el, unit) type(graph_element_t), intent(in) :: el integer, intent(in), optional :: unit type(graph_options_t), pointer :: gro type(string_t) :: id integer :: u u = given_output_unit (unit); if (u < 0) return gro => graph_element_get_graph_options_ptr (el) id = graph_options_get_id (gro) write (u, "(A,A)") '#', repeat ("-", 78) select case (el%type) case (AN_HISTOGRAM) write (u, "(A)", advance="no") "# Histogram: " write (u, "(1x,A)") char (id) call histogram_write (el%h, unit) case (AN_PLOT) write (u, "(A)", advance="no") "# Plot: " write (u, "(1x,A)") char (id) call plot_write (el%p, unit) end select end subroutine graph_element_write @ %def graph_element_write <>= subroutine graph_element_write_gml_reader (el, filename, unit) type(graph_element_t), intent(in) :: el type(string_t), intent(in) :: filename integer, intent(in), optional :: unit select case (el%type) case (AN_HISTOGRAM); call histogram_write_gml_reader (el%h, filename, unit) case (AN_PLOT); call plot_write_gml_reader (el%p, filename, unit) end select end subroutine graph_element_write_gml_reader @ %def graph_element_write_gml_reader @ \subsubsection{The graph type} The actual graph type contains its own [[graph_options]], which override the individual settings. The [[drawing_options]] are set in the graph elements. This distinction motivates the separation of the two types. <>= type :: graph_t private type(graph_element_t), dimension(:), allocatable :: el type(graph_options_t) :: graph_options end type graph_t @ %def graph_t @ \subsubsection{Initializer/finalizer} The graph is created with a definite number of elements. The elements are filled one by one, optionally with modified drawing options. <>= subroutine graph_init (g, id, n_elements, graph_options) type(graph_t), intent(out) :: g type(string_t), intent(in) :: id integer, intent(in) :: n_elements type(graph_options_t), intent(in), optional :: graph_options allocate (g%el (n_elements)) if (present (graph_options)) then g%graph_options = graph_options else call graph_options_init (g%graph_options) end if call graph_options_set (g%graph_options, id = id) end subroutine graph_init @ %def graph_init <>= subroutine graph_insert_histogram (g, i, h, drawing_options) type(graph_t), intent(inout), target :: g integer, intent(in) :: i type(histogram_t), intent(in) :: h type(drawing_options_t), intent(in), optional :: drawing_options type(graph_options_t), pointer :: gro type(drawing_options_t), pointer :: dro type(string_t) :: id g%el(i)%type = AN_HISTOGRAM allocate (g%el(i)%h) call histogram_init_histogram (g%el(i)%h, h, drawing_options) gro => histogram_get_graph_options_ptr (g%el(i)%h) dro => histogram_get_drawing_options_ptr (g%el(i)%h) id = graph_options_get_id (gro) call drawing_options_set (dro, dataset = "dat." // id) end subroutine graph_insert_histogram @ %def graph_insert_histogram <>= subroutine graph_insert_plot (g, i, p, drawing_options) type(graph_t), intent(inout) :: g integer, intent(in) :: i type(plot_t), intent(in) :: p type(drawing_options_t), intent(in), optional :: drawing_options type(graph_options_t), pointer :: gro type(drawing_options_t), pointer :: dro type(string_t) :: id g%el(i)%type = AN_PLOT allocate (g%el(i)%p) call plot_init_plot (g%el(i)%p, p, drawing_options) gro => plot_get_graph_options_ptr (g%el(i)%p) dro => plot_get_drawing_options_ptr (g%el(i)%p) id = graph_options_get_id (gro) call drawing_options_set (dro, dataset = "dat." // id) end subroutine graph_insert_plot @ %def graph_insert_plot @ Finalizer. <>= subroutine graph_final (g) type(graph_t), intent(inout) :: g integer :: i do i = 1, size (g%el) call graph_element_final (g%el(i)) end do deallocate (g%el) end subroutine graph_final @ %def graph_final @ \subsubsection{Access contents} The number of elements. <>= function graph_get_n_elements (graph) result (n) integer :: n type(graph_t), intent(in) :: graph n = size (graph%el) end function graph_get_n_elements @ %def graph_get_n_elements @ Retrieve a pointer to the drawing options of an element, so they can be modified. (The [[target]] attribute is not actually needed because the components are pointers.) <>= function graph_get_drawing_options_ptr (g, i) result (ptr) type(drawing_options_t), pointer :: ptr type(graph_t), intent(in), target :: g integer, intent(in) :: i ptr => graph_element_get_drawing_options_ptr (g%el(i)) end function graph_get_drawing_options_ptr @ %def graph_get_drawing_options_ptr @ \subsubsection{Output} The default output format just writes histogram and plot data. <>= subroutine graph_write (graph, unit) type(graph_t), intent(in) :: graph integer, intent(in), optional :: unit integer :: i do i = 1, size (graph%el) call graph_element_write (graph%el(i), unit) end do end subroutine graph_write @ %def graph_write @ The GAMELAN driver is not a simple wrapper, but it writes the plot/histogram contents embedded the complete graph. First, data are read in, global background commands next, then individual elements, then global foreground commands. <>= subroutine graph_write_gml_driver (g, filename, unit) type(graph_t), intent(in) :: g type(string_t), intent(in) :: filename type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd integer, intent(in), optional :: unit type(drawing_options_t), pointer :: dro integer :: u, i u = given_output_unit (unit); if (u < 0) return call graph_options_write_tex_header (g%graph_options, unit) write (u, "(2x,A)") & char (graph_options_get_gml_setup (g%graph_options)) write (u, "(2x,A)") & char (graph_options_get_gml_graphrange (g%graph_options)) do i = 1, size (g%el) call graph_element_write_gml_reader (g%el(i), filename, unit) calc_cmd = drawing_options_get_calc_command & (graph_element_get_drawing_options_ptr (g%el(i))) if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd) end do bg_cmd = graph_options_get_gml_bg_command (g%graph_options) if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd) do i = 1, size (g%el) dro => graph_element_get_drawing_options_ptr (g%el(i)) bg_cmd = drawing_options_get_gml_bg_command (dro) if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd) draw_cmd = drawing_options_get_draw_command (dro) if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd) err_cmd = drawing_options_get_err_command (dro) if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd) symb_cmd = drawing_options_get_symb_command (dro) if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd) fg_cmd = drawing_options_get_gml_fg_command (dro) if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd) end do fg_cmd = graph_options_get_gml_fg_command (g%graph_options) if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd) write (u, "(2x,A)") char (graph_options_get_gml_x_label (g%graph_options)) write (u, "(2x,A)") char (graph_options_get_gml_y_label (g%graph_options)) call graph_options_write_tex_footer (g%graph_options, unit) end subroutine graph_write_gml_driver @ %def graph_write_gml_driver @ Append header for generic data output in ifile format. <>= subroutine graph_get_header (graph, header, comment) type(graph_t), intent(in) :: graph type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment type(string_t) :: c if (present (comment)) then c = comment else c = "" end if call ifile_append (header, c // "WHIZARD graph data") call graph_options_get_header (graph%graph_options, header, comment) call ifile_append (header, & c // "number of graph elements: " & // int2char (graph_get_n_elements (graph))) end subroutine graph_get_header @ %def graph_get_header @ \subsection{Analysis objects} This data structure holds all observables, histograms and such that are currently active. We have one global store; individual items are identified by their ID strings. (This should rather be coded by type extension.) <>= integer, parameter :: AN_UNDEFINED = 0 integer, parameter :: AN_OBSERVABLE = 1 integer, parameter :: AN_HISTOGRAM = 2 integer, parameter :: AN_PLOT = 3 integer, parameter :: AN_GRAPH = 4 <>= public :: AN_UNDEFINED, AN_HISTOGRAM, AN_OBSERVABLE, AN_PLOT, AN_GRAPH @ %def AN_UNDEFINED @ %def AN_OBSERVABLE AN_HISTOGRAM AN_PLOT AN_GRAPH <>= type :: analysis_object_t private type(string_t) :: id integer :: type = AN_UNDEFINED type(observable_t), pointer :: obs => null () type(histogram_t), pointer :: h => null () type(plot_t), pointer :: p => null () type(graph_t), pointer :: g => null () type(analysis_object_t), pointer :: next => null () end type analysis_object_t @ %def analysis_object_t @ \subsubsection{Initializer/finalizer} Allocate with the correct type but do not fill initial values. <>= subroutine analysis_object_init (obj, id, type) type(analysis_object_t), intent(out) :: obj type(string_t), intent(in) :: id integer, intent(in) :: type obj%id = id obj%type = type select case (obj%type) case (AN_OBSERVABLE); allocate (obj%obs) case (AN_HISTOGRAM); allocate (obj%h) case (AN_PLOT); allocate (obj%p) case (AN_GRAPH); allocate (obj%g) end select end subroutine analysis_object_init @ %def analysis_object_init <>= subroutine analysis_object_final (obj) type(analysis_object_t), intent(inout) :: obj select case (obj%type) case (AN_OBSERVABLE) deallocate (obj%obs) case (AN_HISTOGRAM) deallocate (obj%h) case (AN_PLOT) call plot_final (obj%p) deallocate (obj%p) case (AN_GRAPH) call graph_final (obj%g) deallocate (obj%g) end select obj%type = AN_UNDEFINED end subroutine analysis_object_final @ %def analysis_object_final @ Clear the analysis object, i.e., reset it to its initial state. Not applicable to graphs, which are always combinations of other existing objects. <>= subroutine analysis_object_clear (obj) type(analysis_object_t), intent(inout) :: obj select case (obj%type) case (AN_OBSERVABLE) call observable_clear (obj%obs) case (AN_HISTOGRAM) call histogram_clear (obj%h) case (AN_PLOT) call plot_clear (obj%p) end select end subroutine analysis_object_clear @ %def analysis_object_clear @ \subsubsection{Fill with data} Record data. The effect depends on the type of analysis object. <>= subroutine analysis_object_record_data (obj, & x, y, yerr, xerr, weight, excess, success) type(analysis_object_t), intent(inout) :: obj real(default), intent(in) :: x real(default), intent(in), optional :: y, yerr, xerr, weight, excess logical, intent(out), optional :: success select case (obj%type) case (AN_OBSERVABLE) if (present (weight)) then call observable_record_value_weighted (obj%obs, x, weight, success) else call observable_record_value_unweighted (obj%obs, x, success) end if case (AN_HISTOGRAM) if (present (weight)) then call histogram_record_value_weighted (obj%h, x, weight, success) else call histogram_record_value_unweighted (obj%h, x, excess, success) end if case (AN_PLOT) if (present (y)) then call plot_record_value (obj%p, x, y, yerr, xerr, success) else if (present (success)) success = .false. end if case default if (present (success)) success = .false. end select end subroutine analysis_object_record_data @ %def analysis_object_record_data @ Explicitly set the pointer to the next object in the list. <>= subroutine analysis_object_set_next_ptr (obj, next) type(analysis_object_t), intent(inout) :: obj type(analysis_object_t), pointer :: next obj%next => next end subroutine analysis_object_set_next_ptr @ %def analysis_object_set_next_ptr @ \subsubsection{Access contents} Return a pointer to the next object in the list. <>= function analysis_object_get_next_ptr (obj) result (next) type(analysis_object_t), pointer :: next type(analysis_object_t), intent(in) :: obj next => obj%next end function analysis_object_get_next_ptr @ %def analysis_object_get_next_ptr @ Return data as appropriate for the object type. <>= function analysis_object_get_n_elements (obj) result (n) integer :: n type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_HISTOGRAM) n = 1 case (AN_PLOT) n = 1 case (AN_GRAPH) n = graph_get_n_elements (obj%g) case default n = 0 end select end function analysis_object_get_n_elements function analysis_object_get_n_entries (obj, within_bounds) result (n) integer :: n type(analysis_object_t), intent(in) :: obj logical, intent(in), optional :: within_bounds logical :: wb select case (obj%type) case (AN_OBSERVABLE) n = observable_get_n_entries (obj%obs) case (AN_HISTOGRAM) wb = .false.; if (present (within_bounds)) wb = within_bounds if (wb) then n = histogram_get_n_entries_within_bounds (obj%h) else n = histogram_get_n_entries (obj%h) end if case (AN_PLOT) n = plot_get_n_entries (obj%p) case default n = 0 end select end function analysis_object_get_n_entries function analysis_object_get_average (obj, within_bounds) result (avg) real(default) :: avg type(analysis_object_t), intent(in) :: obj logical, intent(in), optional :: within_bounds logical :: wb select case (obj%type) case (AN_OBSERVABLE) avg = observable_get_average (obj%obs) case (AN_HISTOGRAM) wb = .false.; if (present (within_bounds)) wb = within_bounds if (wb) then avg = histogram_get_average_within_bounds (obj%h) else avg = histogram_get_average (obj%h) end if case default avg = 0 end select end function analysis_object_get_average function analysis_object_get_error (obj, within_bounds) result (err) real(default) :: err type(analysis_object_t), intent(in) :: obj logical, intent(in), optional :: within_bounds logical :: wb select case (obj%type) case (AN_OBSERVABLE) err = observable_get_error (obj%obs) case (AN_HISTOGRAM) wb = .false.; if (present (within_bounds)) wb = within_bounds if (wb) then err = histogram_get_error_within_bounds (obj%h) else err = histogram_get_error (obj%h) end if case default err = 0 end select end function analysis_object_get_error @ %def analysis_object_get_n_elements @ %def analysis_object_get_n_entries @ %def analysis_object_get_average @ %def analysis_object_get_error @ Return pointers to the actual contents: <>= function analysis_object_get_observable_ptr (obj) result (obs) type(observable_t), pointer :: obs type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_OBSERVABLE); obs => obj%obs case default; obs => null () end select end function analysis_object_get_observable_ptr function analysis_object_get_histogram_ptr (obj) result (h) type(histogram_t), pointer :: h type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_HISTOGRAM); h => obj%h case default; h => null () end select end function analysis_object_get_histogram_ptr function analysis_object_get_plot_ptr (obj) result (plot) type(plot_t), pointer :: plot type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_PLOT); plot => obj%p case default; plot => null () end select end function analysis_object_get_plot_ptr function analysis_object_get_graph_ptr (obj) result (g) type(graph_t), pointer :: g type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_GRAPH); g => obj%g case default; g => null () end select end function analysis_object_get_graph_ptr @ %def analysis_object_get_observable_ptr @ %def analysis_object_get_histogram_ptr @ %def analysis_object_get_plot_ptr @ %def analysis_object_get_graph_ptr @ Return true if the object has a graphical representation: <>= function analysis_object_has_plot (obj) result (flag) logical :: flag type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_HISTOGRAM); flag = .true. case (AN_PLOT); flag = .true. case (AN_GRAPH); flag = .true. case default; flag = .false. end select end function analysis_object_has_plot @ %def analysis_object_has_plot @ \subsubsection{Output} <>= subroutine analysis_object_write (obj, unit, verbose) type(analysis_object_t), intent(in) :: obj integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical :: verb integer :: u u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose write (u, "(A)") repeat ("#", 79) select case (obj%type) case (AN_OBSERVABLE) write (u, "(A)", advance="no") "# Observable:" case (AN_HISTOGRAM) write (u, "(A)", advance="no") "# Histogram: " case (AN_PLOT) write (u, "(A)", advance="no") "# Plot: " case (AN_GRAPH) write (u, "(A)", advance="no") "# Graph: " case default write (u, "(A)") "# [undefined analysis object]" return end select write (u, "(1x,A)") char (obj%id) select case (obj%type) case (AN_OBSERVABLE) call observable_write (obj%obs, unit) case (AN_HISTOGRAM) if (verb) then call graph_options_write (obj%h%graph_options, unit) write (u, *) call drawing_options_write (obj%h%drawing_options, unit) write (u, *) end if call histogram_write (obj%h, unit) case (AN_PLOT) if (verb) then call graph_options_write (obj%p%graph_options, unit) write (u, *) call drawing_options_write (obj%p%drawing_options, unit) write (u, *) end if call plot_write (obj%p, unit) case (AN_GRAPH) call graph_write (obj%g, unit) end select end subroutine analysis_object_write @ %def analysis_object_write @ Write the object part of the \LaTeX\ driver file. <>= subroutine analysis_object_write_driver (obj, filename, unit) type(analysis_object_t), intent(in) :: obj type(string_t), intent(in) :: filename integer, intent(in), optional :: unit select case (obj%type) case (AN_OBSERVABLE) call observable_write_driver (obj%obs, unit) case (AN_HISTOGRAM) call histogram_write_gml_driver (obj%h, filename, unit) case (AN_PLOT) call plot_write_gml_driver (obj%p, filename, unit) case (AN_GRAPH) call graph_write_gml_driver (obj%g, filename, unit) end select end subroutine analysis_object_write_driver @ %def analysis_object_write_driver @ Return a data header for external formats, in ifile form. <>= subroutine analysis_object_get_header (obj, header, comment) type(analysis_object_t), intent(in) :: obj type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment select case (obj%type) case (AN_HISTOGRAM) call histogram_get_header (obj%h, header, comment) case (AN_PLOT) call plot_get_header (obj%p, header, comment) end select end subroutine analysis_object_get_header @ %def analysis_object_get_header @ \subsection{Analysis object iterator} Analysis objects are containers which have iterable data structures: histograms/bins and plots/points. If they are to be treated on a common basis, it is useful to have an iterator which hides the implementation details. The iterator is used only for elementary analysis objects that contain plot data: histograms or plots. It is invalid for meta-objects (graphs) and non-graphical objects (observables). <>= public :: analysis_iterator_t <>= type :: analysis_iterator_t private integer :: type = AN_UNDEFINED type(analysis_object_t), pointer :: object => null () integer :: index = 1 type(point_t), pointer :: point => null () end type @ %def analysis_iterator_t @ The initializer places the iterator at the beginning of the analysis object. <>= subroutine analysis_iterator_init (iterator, object) type(analysis_iterator_t), intent(out) :: iterator type(analysis_object_t), intent(in), target :: object iterator%object => object if (associated (iterator%object)) then iterator%type = iterator%object%type select case (iterator%type) case (AN_PLOT) iterator%point => iterator%object%p%first end select end if end subroutine analysis_iterator_init @ %def analysis_iterator_init @ The iterator is valid as long as it points to an existing entry. An iterator for a data object without array data (observable) is always invalid. <>= public :: analysis_iterator_is_valid <>= function analysis_iterator_is_valid (iterator) result (valid) logical :: valid type(analysis_iterator_t), intent(in) :: iterator if (associated (iterator%object)) then select case (iterator%type) case (AN_HISTOGRAM) valid = iterator%index <= histogram_get_n_bins (iterator%object%h) case (AN_PLOT) valid = associated (iterator%point) case default valid = .false. end select else valid = .false. end if end function analysis_iterator_is_valid @ %def analysis_iterator_is_valid @ Advance the iterator. <>= public :: analysis_iterator_advance <>= subroutine analysis_iterator_advance (iterator) type(analysis_iterator_t), intent(inout) :: iterator if (associated (iterator%object)) then select case (iterator%type) case (AN_PLOT) iterator%point => iterator%point%next end select iterator%index = iterator%index + 1 end if end subroutine analysis_iterator_advance @ %def analysis_iterator_advance @ Retrieve the object type: <>= public :: analysis_iterator_get_type <>= function analysis_iterator_get_type (iterator) result (type) integer :: type type(analysis_iterator_t), intent(in) :: iterator type = iterator%type end function analysis_iterator_get_type @ %def analysis_iterator_get_type @ Use the iterator to retrieve data. We implement a common routine which takes the data descriptors as optional arguments. Data which do not occur in the selected type trigger to an error condition. The iterator must point to a valid entry. <>= public :: analysis_iterator_get_data <>= subroutine analysis_iterator_get_data (iterator, & x, y, yerr, xerr, width, excess, index, n_total) type(analysis_iterator_t), intent(in) :: iterator real(default), intent(out), optional :: x, y, yerr, xerr, width, excess integer, intent(out), optional :: index, n_total select case (iterator%type) case (AN_HISTOGRAM) if (present (x)) & x = bin_get_midpoint (iterator%object%h%bin(iterator%index)) if (present (y)) & y = bin_get_sum (iterator%object%h%bin(iterator%index)) if (present (yerr)) & yerr = bin_get_error (iterator%object%h%bin(iterator%index)) if (present (xerr)) & call invalid ("histogram", "xerr") if (present (width)) & width = bin_get_width (iterator%object%h%bin(iterator%index)) if (present (excess)) & excess = bin_get_excess (iterator%object%h%bin(iterator%index)) if (present (index)) & index = iterator%index if (present (n_total)) & n_total = histogram_get_n_bins (iterator%object%h) case (AN_PLOT) if (present (x)) & x = point_get_x (iterator%point) if (present (y)) & y = point_get_y (iterator%point) if (present (yerr)) & yerr = point_get_yerr (iterator%point) if (present (xerr)) & xerr = point_get_xerr (iterator%point) if (present (width)) & call invalid ("plot", "width") if (present (excess)) & call invalid ("plot", "excess") if (present (index)) & index = iterator%index if (present (n_total)) & n_total = plot_get_n_entries (iterator%object%p) case default call msg_bug ("analysis_iterator_get_data: called " & // "for unsupported analysis object type") end select contains subroutine invalid (typestr, objstr) character(*), intent(in) :: typestr, objstr call msg_bug ("analysis_iterator_get_data: attempt to get '" & // objstr // "' for type '" // typestr // "'") end subroutine invalid end subroutine analysis_iterator_get_data @ %def analysis_iterator_get_data @ \subsection{Analysis store} This data structure holds all observables, histograms and such that are currently active. We have one global store; individual items are identified by their ID strings and types. <>= type(analysis_store_t), save :: analysis_store @ %def analysis_store <>= type :: analysis_store_t private type(analysis_object_t), pointer :: first => null () type(analysis_object_t), pointer :: last => null () end type analysis_store_t @ %def analysis_store_t @ Delete the analysis store <>= public :: analysis_final <>= subroutine analysis_final () type(analysis_object_t), pointer :: current do while (associated (analysis_store%first)) current => analysis_store%first analysis_store%first => current%next call analysis_object_final (current) end do analysis_store%last => null () end subroutine analysis_final @ %def analysis_final @ Append a new analysis object <>= subroutine analysis_store_append_object (id, type) type(string_t), intent(in) :: id integer, intent(in) :: type type(analysis_object_t), pointer :: obj allocate (obj) call analysis_object_init (obj, id, type) if (associated (analysis_store%last)) then analysis_store%last%next => obj else analysis_store%first => obj end if analysis_store%last => obj end subroutine analysis_store_append_object @ %def analysis_store_append_object @ Return a pointer to the analysis object with given ID. <>= function analysis_store_get_object_ptr (id) result (obj) type(string_t), intent(in) :: id type(analysis_object_t), pointer :: obj obj => analysis_store%first do while (associated (obj)) if (obj%id == id) return obj => obj%next end do end function analysis_store_get_object_ptr @ %def analysis_store_get_object_ptr @ Initialize an analysis object: either reset it if present, or append a new entry. <>= subroutine analysis_store_init_object (id, type, obj) type(string_t), intent(in) :: id integer, intent(in) :: type type(analysis_object_t), pointer :: obj, next obj => analysis_store_get_object_ptr (id) if (associated (obj)) then next => analysis_object_get_next_ptr (obj) call analysis_object_final (obj) call analysis_object_init (obj, id, type) call analysis_object_set_next_ptr (obj, next) else call analysis_store_append_object (id, type) obj => analysis_store%last end if end subroutine analysis_store_init_object @ %def analysis_store_init_object @ Get the type of a analysis object <>= public :: analysis_store_get_object_type <>= function analysis_store_get_object_type (id) result (type) type(string_t), intent(in) :: id integer :: type type(analysis_object_t), pointer :: object object => analysis_store_get_object_ptr (id) if (associated (object)) then type = object%type else type = AN_UNDEFINED end if end function analysis_store_get_object_type @ %def analysis_store_get_object_type @ Return the number of objects in the store. <>= function analysis_store_get_n_objects () result (n) integer :: n type(analysis_object_t), pointer :: current n = 0 current => analysis_store%first do while (associated (current)) n = n + 1 current => current%next end do end function analysis_store_get_n_objects @ %def analysis_store_get_n_objects @ Allocate an array and fill it with all existing IDs. <>= public :: analysis_store_get_ids <>= subroutine analysis_store_get_ids (id) type(string_t), dimension(:), allocatable, intent(out) :: id type(analysis_object_t), pointer :: current integer :: i allocate (id (analysis_store_get_n_objects())) i = 0 current => analysis_store%first do while (associated (current)) i = i + 1 id(i) = current%id current => current%next end do end subroutine analysis_store_get_ids @ %def analysis_store_get_ids @ \subsection{\LaTeX\ driver file} Write a driver file for all objects in the store. <>= subroutine analysis_store_write_driver_all (filename_data, unit) type(string_t), intent(in) :: filename_data integer, intent(in), optional :: unit type(analysis_object_t), pointer :: obj call analysis_store_write_driver_header (unit) obj => analysis_store%first do while (associated (obj)) call analysis_object_write_driver (obj, filename_data, unit) obj => obj%next end do call analysis_store_write_driver_footer (unit) end subroutine analysis_store_write_driver_all @ %def analysis_store_write_driver_all @ Write a driver file for an array of objects. <>= subroutine analysis_store_write_driver_obj (filename_data, id, unit) type(string_t), intent(in) :: filename_data type(string_t), dimension(:), intent(in) :: id integer, intent(in), optional :: unit type(analysis_object_t), pointer :: obj integer :: i call analysis_store_write_driver_header (unit) do i = 1, size (id) obj => analysis_store_get_object_ptr (id(i)) if (associated (obj)) & call analysis_object_write_driver (obj, filename_data, unit) end do call analysis_store_write_driver_footer (unit) end subroutine analysis_store_write_driver_obj @ %def analysis_store_write_driver_obj @ The beginning of the driver file. <>= subroutine analysis_store_write_driver_header (unit) integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, '(A)') "\documentclass[12pt]{article}" write (u, *) write (u, '(A)') "\usepackage{gamelan}" write (u, '(A)') "\usepackage{amsmath}" write (u, '(A)') "\usepackage{ifpdf}" write (u, '(A)') "\ifpdf" write (u, '(A)') " \DeclareGraphicsRule{*}{mps}{*}{}" write (u, '(A)') "\else" write (u, '(A)') " \DeclareGraphicsRule{*}{eps}{*}{}" write (u, '(A)') "\fi" write (u, *) write (u, '(A)') "\begin{document}" write (u, '(A)') "\begin{gmlfile}" write (u, *) write (u, '(A)') "\begin{gmlcode}" write (u, '(A)') " color col.default, col.excess;" write (u, '(A)') " col.default = 0.9white;" write (u, '(A)') " col.excess = red;" write (u, '(A)') " boolean show_excess;" !!! Future excess options for plots ! if (mcs(1)%plot_excess .and. mcs(1)%unweighted) then ! write (u, '(A)') " show_excess = true;" ! else write (u, '(A)') " show_excess = false;" ! end if write (u, '(A)') "\end{gmlcode}" write (u, *) end subroutine analysis_store_write_driver_header @ %def analysis_store_write_driver_header @ The end of the driver file. <>= subroutine analysis_store_write_driver_footer (unit) integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write(u, *) write(u, '(A)') "\end{gmlfile}" write(u, '(A)') "\end{document}" end subroutine analysis_store_write_driver_footer @ %def analysis_store_write_driver_footer @ \subsection{API} \subsubsection{Creating new objects} The specific versions below: <>= public :: analysis_init_observable <>= subroutine analysis_init_observable (id, obs_label, obs_unit, graph_options) type(string_t), intent(in) :: id type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(analysis_object_t), pointer :: obj type(observable_t), pointer :: obs call analysis_store_init_object (id, AN_OBSERVABLE, obj) obs => analysis_object_get_observable_ptr (obj) call observable_init (obs, obs_label, obs_unit, graph_options) end subroutine analysis_init_observable @ %def analysis_init_observable <>= public :: analysis_init_histogram <>= interface analysis_init_histogram module procedure analysis_init_histogram_n_bins module procedure analysis_init_histogram_bin_width end interface <>= subroutine analysis_init_histogram_n_bins & (id, lower_bound, upper_bound, n_bins, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound integer, intent(in) :: n_bins logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options type(analysis_object_t), pointer :: obj type(histogram_t), pointer :: h call analysis_store_init_object (id, AN_HISTOGRAM, obj) h => analysis_object_get_histogram_ptr (obj) call histogram_init (h, id, & lower_bound, upper_bound, n_bins, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) end subroutine analysis_init_histogram_n_bins subroutine analysis_init_histogram_bin_width & (id, lower_bound, upper_bound, bin_width, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound, bin_width logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options type(analysis_object_t), pointer :: obj type(histogram_t), pointer :: h call analysis_store_init_object (id, AN_HISTOGRAM, obj) h => analysis_object_get_histogram_ptr (obj) call histogram_init (h, id, & lower_bound, upper_bound, bin_width, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) end subroutine analysis_init_histogram_bin_width @ %def analysis_init_histogram_n_bins @ %def analysis_init_histogram_bin_width <>= public :: analysis_init_plot <>= subroutine analysis_init_plot (id, graph_options, drawing_options) type(string_t), intent(in) :: id type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options type(analysis_object_t), pointer :: obj type(plot_t), pointer :: plot call analysis_store_init_object (id, AN_PLOT, obj) plot => analysis_object_get_plot_ptr (obj) call plot_init (plot, id, graph_options, drawing_options) end subroutine analysis_init_plot @ %def analysis_init_plot <>= public :: analysis_init_graph <>= subroutine analysis_init_graph (id, n_elements, graph_options) type(string_t), intent(in) :: id integer, intent(in) :: n_elements type(graph_options_t), intent(in), optional :: graph_options type(analysis_object_t), pointer :: obj type(graph_t), pointer :: graph call analysis_store_init_object (id, AN_GRAPH, obj) graph => analysis_object_get_graph_ptr (obj) call graph_init (graph, id, n_elements, graph_options) end subroutine analysis_init_graph @ %def analysis_init_graph @ \subsubsection{Recording data} This procedure resets an object or the whole store to its initial state. <>= public :: analysis_clear <>= interface analysis_clear module procedure analysis_store_clear_obj module procedure analysis_store_clear_all end interface <>= subroutine analysis_store_clear_obj (id) type(string_t), intent(in) :: id type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) then call analysis_object_clear (obj) end if end subroutine analysis_store_clear_obj subroutine analysis_store_clear_all () type(analysis_object_t), pointer :: obj obj => analysis_store%first do while (associated (obj)) call analysis_object_clear (obj) obj => obj%next end do end subroutine analysis_store_clear_all @ %def analysis_clear @ There is one generic recording function whose behavior depends on the type of analysis object. <>= public :: analysis_record_data <>= subroutine analysis_record_data (id, x, y, yerr, xerr, & weight, excess, success, exist) type(string_t), intent(in) :: id real(default), intent(in) :: x real(default), intent(in), optional :: y, yerr, xerr, weight, excess logical, intent(out), optional :: success, exist type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) then call analysis_object_record_data (obj, x, y, yerr, xerr, & weight, excess, success) if (present (exist)) exist = .true. else if (present (success)) success = .false. if (present (exist)) exist = .false. end if end subroutine analysis_record_data @ %def analysis_record_data @ \subsubsection{Build a graph} This routine sets up the array of graph elements by copying the graph elements given as input. The object must exist and already be initialized as a graph. <>= public :: analysis_fill_graph <>= subroutine analysis_fill_graph (id, i, id_in, drawing_options) type(string_t), intent(in) :: id integer, intent(in) :: i type(string_t), intent(in) :: id_in type(drawing_options_t), intent(in), optional :: drawing_options type(analysis_object_t), pointer :: obj type(graph_t), pointer :: g type(histogram_t), pointer :: h type(plot_t), pointer :: p obj => analysis_store_get_object_ptr (id) g => analysis_object_get_graph_ptr (obj) obj => analysis_store_get_object_ptr (id_in) if (associated (obj)) then select case (obj%type) case (AN_HISTOGRAM) h => analysis_object_get_histogram_ptr (obj) call graph_insert_histogram (g, i, h, drawing_options) case (AN_PLOT) p => analysis_object_get_plot_ptr (obj) call graph_insert_plot (g, i, p, drawing_options) case default call msg_error ("Graph '" // char (id) // "': Element '" & // char (id_in) // "' is neither histogram nor plot.") end select else call msg_error ("Graph '" // char (id) // "': Element '" & // char (id_in) // "' is undefined.") end if end subroutine analysis_fill_graph @ %def analysis_fill_graph @ \subsubsection{Retrieve generic results} Check if a named object exists. <>= public :: analysis_exists <>= function analysis_exists (id) result (flag) type(string_t), intent(in) :: id logical :: flag type(analysis_object_t), pointer :: obj flag = .true. obj => analysis_store%first do while (associated (obj)) if (obj%id == id) return obj => obj%next end do flag = .false. end function analysis_exists @ %def analysis_exists @ The following functions should work for all kinds of analysis object: <>= public :: analysis_get_n_elements public :: analysis_get_n_entries public :: analysis_get_average public :: analysis_get_error <>= function analysis_get_n_elements (id) result (n) integer :: n type(string_t), intent(in) :: id type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) then n = analysis_object_get_n_elements (obj) else n = 0 end if end function analysis_get_n_elements function analysis_get_n_entries (id, within_bounds) result (n) integer :: n type(string_t), intent(in) :: id logical, intent(in), optional :: within_bounds type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) then n = analysis_object_get_n_entries (obj, within_bounds) else n = 0 end if end function analysis_get_n_entries function analysis_get_average (id, within_bounds) result (avg) real(default) :: avg type(string_t), intent(in) :: id type(analysis_object_t), pointer :: obj logical, intent(in), optional :: within_bounds obj => analysis_store_get_object_ptr (id) if (associated (obj)) then avg = analysis_object_get_average (obj, within_bounds) else avg = 0 end if end function analysis_get_average function analysis_get_error (id, within_bounds) result (err) real(default) :: err type(string_t), intent(in) :: id type(analysis_object_t), pointer :: obj logical, intent(in), optional :: within_bounds obj => analysis_store_get_object_ptr (id) if (associated (obj)) then err = analysis_object_get_error (obj, within_bounds) else err = 0 end if end function analysis_get_error @ %def analysis_get_n_elements @ %def analysis_get_n_entries @ %def analysis_get_average @ %def analysis_get_error @ Return true if any analysis object is graphical <>= public :: analysis_has_plots <>= interface analysis_has_plots module procedure analysis_has_plots_any module procedure analysis_has_plots_obj end interface <>= function analysis_has_plots_any () result (flag) logical :: flag type(analysis_object_t), pointer :: obj flag = .false. obj => analysis_store%first do while (associated (obj)) flag = analysis_object_has_plot (obj) if (flag) return end do end function analysis_has_plots_any function analysis_has_plots_obj (id) result (flag) logical :: flag type(string_t), dimension(:), intent(in) :: id type(analysis_object_t), pointer :: obj integer :: i flag = .false. do i = 1, size (id) obj => analysis_store_get_object_ptr (id(i)) if (associated (obj)) then flag = analysis_object_has_plot (obj) if (flag) return end if end do end function analysis_has_plots_obj @ %def analysis_has_plots @ \subsubsection{Iterators} Initialize an iterator for the given object. If the object does not exist or has wrong type, the iterator will be invalid. <>= public :: analysis_init_iterator <>= subroutine analysis_init_iterator (id, iterator) type(string_t), intent(in) :: id type(analysis_iterator_t), intent(out) :: iterator type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) call analysis_iterator_init (iterator, obj) end subroutine analysis_init_iterator @ %def analysis_init_iterator @ \subsubsection{Output} <>= public :: analysis_write <>= interface analysis_write module procedure analysis_write_object module procedure analysis_write_all end interface @ %def interface <>= subroutine analysis_write_object (id, unit, verbose) type(string_t), intent(in) :: id integer, intent(in), optional :: unit logical, intent(in), optional :: verbose type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) then call analysis_object_write (obj, unit, verbose) else call msg_error ("Analysis object '" // char (id) // "' not found") end if end subroutine analysis_write_object subroutine analysis_write_all (unit, verbose) integer, intent(in), optional :: unit logical, intent(in), optional :: verbose type(analysis_object_t), pointer :: obj integer :: u u = given_output_unit (unit); if (u < 0) return obj => analysis_store%first do while (associated (obj)) call analysis_object_write (obj, unit, verbose) obj => obj%next end do end subroutine analysis_write_all @ %def analysis_write_object @ %def analysis_write_all <>= public :: analysis_write_driver <>= subroutine analysis_write_driver (filename_data, id, unit) type(string_t), intent(in) :: filename_data type(string_t), dimension(:), intent(in), optional :: id integer, intent(in), optional :: unit if (present (id)) then call analysis_store_write_driver_obj (filename_data, id, unit) else call analysis_store_write_driver_all (filename_data, unit) end if end subroutine analysis_write_driver @ %def analysis_write_driver <>= public :: analysis_compile_tex <>= subroutine analysis_compile_tex (file, has_gmlcode, os_data) type(string_t), intent(in) :: file logical, intent(in) :: has_gmlcode type(os_data_t), intent(in) :: os_data integer :: status if (os_data%event_analysis_ps) then call os_system_call ("make compile " // os_data%makeflags // " -f " // & char (file) // "_ana.makefile", status) if (status /= 0) then call msg_error ("Unable to compile analysis output file") end if else call msg_warning ("Skipping results display because " & // "latex/mpost/dvips is not available") end if end subroutine analysis_compile_tex @ %def analysis_compile_tex @ Write header for generic data output to an ifile. <>= public :: analysis_get_header <>= subroutine analysis_get_header (id, header, comment) type(string_t), intent(in) :: id type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment type(analysis_object_t), pointer :: object object => analysis_store_get_object_ptr (id) if (associated (object)) then call analysis_object_get_header (object, header, comment) end if end subroutine analysis_get_header @ %def analysis_get_header @ Write a makefile in order to do the compile steps. <>= public :: analysis_write_makefile <>= subroutine analysis_write_makefile (filename, unit, has_gmlcode, os_data) type(string_t), intent(in) :: filename integer, intent(in) :: unit logical, intent(in) :: has_gmlcode type(os_data_t), intent(in) :: os_data write (unit, "(3A)") "# WHIZARD: Makefile for analysis '", & char (filename), "'" write (unit, "(A)") "# Automatically generated file, do not edit" write (unit, "(A)") "" write (unit, "(A)") "# LaTeX setup" write (unit, "(A)") "LATEX = " // char (os_data%latex) write (unit, "(A)") "MPOST = " // char (os_data%mpost) write (unit, "(A)") "GML = " // char (os_data%gml) write (unit, "(A)") "DVIPS = " // char (os_data%dvips) write (unit, "(A)") "PS2PDF = " // char (os_data%ps2pdf) write (unit, "(A)") 'TEX_FLAGS = "$$TEXINPUTS:' // & char(os_data%whizard_texpath) // '"' write (unit, "(A)") 'MP_FLAGS = "$$MPINPUTS:' // & char(os_data%whizard_texpath) // '"' write (unit, "(A)") "" write (unit, "(5A)") "TEX_SOURCES = ", char (filename), ".tex" if (os_data%event_analysis_pdf) then write (unit, "(5A)") "TEX_OBJECTS = ", char (filename), ".pdf" else write (unit, "(5A)") "TEX_OBJECTS = ", char (filename), ".ps" end if if (os_data%event_analysis_ps) then if (os_data%event_analysis_pdf) then write (unit, "(5A)") char (filename), ".pdf: ", & char (filename), ".tex" else write (unit, "(5A)") char (filename), ".ps: ", & char (filename), ".tex" end if write (unit, "(5A)") TAB, "-TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // & char (filename) // ".tex" if (has_gmlcode) then write (unit, "(5A)") TAB, "$(GML) " // char (filename) write (unit, "(5A)") TAB, "TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // & char (filename) // ".tex" end if write (unit, "(5A)") TAB, "$(DVIPS) -o " // char (filename) // ".ps " // & char (filename) // ".dvi" if (os_data%event_analysis_pdf) then write (unit, "(5A)") TAB, "$(PS2PDF) " // char (filename) // ".ps" end if end if write (unit, "(A)") write (unit, "(A)") "compile: $(TEX_OBJECTS)" write (unit, "(A)") ".PHONY: compile" write (unit, "(A)") write (unit, "(5A)") "CLEAN_OBJECTS = ", char (filename), ".aux" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".log" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".dvi" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".out" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9][0-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9][0-9][0-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9][0-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9][0-9][0-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".ltp" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".mp" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".mpx" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".dvi" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".ps" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".pdf" write (unit, "(A)") write (unit, "(A)") "# Generic cleanup targets" write (unit, "(A)") "clean-objects:" write (unit, "(A)") TAB // "rm -f $(CLEAN_OBJECTS)" write (unit, "(A)") "" write (unit, "(A)") "clean: clean-objects" write (unit, "(A)") ".PHONY: clean" end subroutine analysis_write_makefile @ %def analysis_write_makefile @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[analysis_ut.f90]]>>= <> module analysis_ut use unit_tests use analysis_uti <> <> contains <> end module analysis_ut @ %def analysis_ut @ <<[[analysis_uti.f90]]>>= <> module analysis_uti <> <> use format_defs, only: FMT_19 use analysis <> <> contains <> end module analysis_uti @ %def analysis_ut @ API: driver for the unit tests below. <>= public :: analysis_test <>= subroutine analysis_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine analysis_test @ %def analysis_test <>= call test (analysis_1, "analysis_1", & "check elementary analysis building blocks", & u, results) <>= public :: analysis_1 <>= subroutine analysis_1 (u) integer, intent(in) :: u type(string_t) :: id1, id2, id3, id4 integer :: i id1 = "foo" id2 = "bar" id3 = "hist" id4 = "plot" write (u, "(A)") "* Test output: Analysis" write (u, "(A)") "* Purpose: test the analysis routines" write (u, "(A)") call analysis_init_observable (id1) call analysis_init_observable (id2) call analysis_init_histogram & (id3, 0.5_default, 5.5_default, 1._default, normalize_bins=.false.) call analysis_init_plot (id4) do i = 1, 3 write (u, "(A,1x," // FMT_19 // ")") "data = ", real(i,default) call analysis_record_data (id1, real(i,default)) call analysis_record_data (id2, real(i,default), & weight=real(i,default)) call analysis_record_data (id3, real(i,default)) call analysis_record_data (id4, real(i,default), real(i,default)**2) end do write (u, "(A,10(1x,I5))") "n_entries = ", & analysis_get_n_entries (id1), & analysis_get_n_entries (id2), & analysis_get_n_entries (id3), & analysis_get_n_entries (id3, within_bounds = .true.), & analysis_get_n_entries (id4), & analysis_get_n_entries (id4, within_bounds = .true.) write (u, "(A,10(1x," // FMT_19 // "))") "average = ", & analysis_get_average (id1), & analysis_get_average (id2), & analysis_get_average (id3), & analysis_get_average (id3, within_bounds = .true.) write (u, "(A,10(1x," // FMT_19 // "))") "error = ", & analysis_get_error (id1), & analysis_get_error (id2), & analysis_get_error (id3), & analysis_get_error (id3, within_bounds = .true.) write (u, "(A)") write (u, "(A)") "* Clear analysis #2" write (u, "(A)") call analysis_clear (id2) do i = 4, 6 print *, "data = ", real(i,default) call analysis_record_data (id1, real(i,default)) call analysis_record_data (id2, real(i,default), & weight=real(i,default)) call analysis_record_data (id3, real(i,default)) call analysis_record_data (id4, real(i,default), real(i,default)**2) end do write (u, "(A,10(1x,I5))") "n_entries = ", & analysis_get_n_entries (id1), & analysis_get_n_entries (id2), & analysis_get_n_entries (id3), & analysis_get_n_entries (id3, within_bounds = .true.), & analysis_get_n_entries (id4), & analysis_get_n_entries (id4, within_bounds = .true.) write (u, "(A,10(1x," // FMT_19 // "))") "average = ", & analysis_get_average (id1), & analysis_get_average (id2), & analysis_get_average (id3), & analysis_get_average (id3, within_bounds = .true.) write (u, "(A,10(1x," // FMT_19 // "))") "error = ", & analysis_get_error (id1), & analysis_get_error (id2), & analysis_get_error (id3), & analysis_get_error (id3, within_bounds = .true.) write (u, "(A)") call analysis_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call analysis_clear () call analysis_final () write (u, "(A)") write (u, "(A)") "* Test output end: analysis_1" end subroutine analysis_1 @ %def analysis_1 Index: trunk/src/utilities/utilities.nw =================================================================== --- trunk/src/utilities/utilities.nw (revision 8775) +++ trunk/src/utilities/utilities.nw (revision 8776) @@ -1,3662 +1,3699 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; noweb-code-mode: f90-mode -*- % WHIZARD code as NOWEB source: Utilities \chapter{Utilities} \includemodulegraph{utilities} These modules are intended as part of WHIZARD, but in fact they are generic and could be useful for any purpose. The modules depend only on modules from the [[basics]] set. \begin{description} \item[file\_utils] Procedures that deal with external files, if not covered by Fortran built-ins. \item[file\_registries] Manage files that are accessed by their name. \item[string\_utils] Some string-handling utilities. Includes conversion to C string. \item[format\_utils] Utilities for pretty-printing. \item[format\_defs] Predefined format strings. \item[numeric\_utils] Utilities for comparing numerical values. \item[data\_utils] Utitilies for data structures, i.e. a fixed size queue, polymorphic binary tree and dynamic array list. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{File Utilities} This module provides miscellaneous tools associated with named external files. Currently only: \begin{itemize} \item Delete a named file \end{itemize} <<[[file_utils.f90]]>>= <> module file_utils <> <> interface <> end interface end module file_utils @ %def file_utils <<[[file_utils_sub.f90]]>>= <> submodule (file_utils) file_utils_s use io_units implicit none contains <> end submodule file_utils_s @ %def file_utils_s @ \subsection{Deleting a file} Fortran does not contain a command for deleting a file. Here, we provide a subroutine that deletes a file if it exists. We do not handle the subtleties, so we assume that it is writable if it exists. <>= public :: delete_file <>= module subroutine delete_file (name) character(*), intent(in) :: name end subroutine delete_file <>= module subroutine delete_file (name) character(*), intent(in) :: name logical :: exist integer :: u inquire (file = name, exist = exist) if (exist) then u = free_unit () open (unit = u, file = name) close (u, status = "delete") end if end subroutine delete_file @ %def delete_file @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{File Registries} This module provides a file-registry facility. We can open and close files multiple times without inadvertedly accessing a single file by two different I/O unit numbers. Opening a file the first time enters it into the registry. Opening again just returns the associated I/O unit. The registry maintains a reference count, so closing a file does not actually complete until the last reference is released. File access will always be sequential, however. The file can't be opened at different positions simultaneously. <<[[file_registries.f90]]>>= <> module file_registries <> <> <> <> interface <> end interface end module file_registries @ %def file_registries @ <<[[file_registries_sub.f90]]>>= <> submodule (file_registries) file_registries_s use io_units implicit none contains <> end submodule file_registries_s @ \subsection{File handle} This object holds a filename (fully qualified), the associated unit, and a reference count. The idea is that the object should be deleted when the reference count drops to zero. <>= type :: file_handle_t type(string_t) :: file integer :: unit = 0 integer :: refcount = 0 contains <> end type file_handle_t @ %def file_handle_t @ Debugging output: <>= procedure :: write => file_handle_write <>= module subroutine file_handle_write (handle, u, show_unit) class(file_handle_t), intent(in) :: handle integer, intent(in) :: u logical, intent(in), optional :: show_unit end subroutine file_handle_write <>= module subroutine file_handle_write (handle, u, show_unit) class(file_handle_t), intent(in) :: handle integer, intent(in) :: u logical, intent(in), optional :: show_unit logical :: show_u show_u = .false.; if (present (show_unit)) show_u = show_unit if (show_u) then write (u, "(3x,A,1x,I0,1x,'(',I0,')')") & char (handle%file), handle%unit, handle%refcount else write (u, "(3x,A,1x,'(',I0,')')") & char (handle%file), handle%refcount end if end subroutine file_handle_write @ %def file_handle_write @ Initialize with a file name, don't open the file yet: <>= procedure :: init => file_handle_init <>= module subroutine file_handle_init (handle, file) class(file_handle_t), intent(out) :: handle type(string_t), intent(in) :: file end subroutine file_handle_init <>= module subroutine file_handle_init (handle, file) class(file_handle_t), intent(out) :: handle type(string_t), intent(in) :: file handle%file = file end subroutine file_handle_init @ %def file_handle_init @ We check the [[refcount]] before actually opening the file. <>= procedure :: open => file_handle_open <>= module subroutine file_handle_open (handle) class(file_handle_t), intent(inout) :: handle end subroutine file_handle_open <>= module subroutine file_handle_open (handle) class(file_handle_t), intent(inout) :: handle if (handle%refcount == 0) then handle%unit = free_unit () open (unit = handle%unit, file = char (handle%file), action = "read", & status = "old") end if handle%refcount = handle%refcount + 1 end subroutine file_handle_open @ %def file_handle_open @ Analogously, close if the refcount drops to zero. The caller may then delete the object. <>= procedure :: close => file_handle_close <>= module subroutine file_handle_close (handle) class(file_handle_t), intent(inout) :: handle end subroutine file_handle_close <>= module subroutine file_handle_close (handle) class(file_handle_t), intent(inout) :: handle handle%refcount = handle%refcount - 1 if (handle%refcount == 0) then close (handle%unit) handle%unit = 0 end if end subroutine file_handle_close @ %def file_handle_close @ The I/O unit will be nonzero when the file is open. <>= procedure :: is_open => file_handle_is_open <>= module function file_handle_is_open (handle) result (flag) class(file_handle_t), intent(in) :: handle logical :: flag end function file_handle_is_open <>= module function file_handle_is_open (handle) result (flag) class(file_handle_t), intent(in) :: handle logical :: flag flag = handle%unit /= 0 end function file_handle_is_open @ %def file_handle_is_open @ Return the filename, so we can identify the entry. <>= procedure :: get_file => file_handle_get_file <>= module function file_handle_get_file (handle) result (file) class(file_handle_t), intent(in) :: handle type(string_t) :: file end function file_handle_get_file <>= module function file_handle_get_file (handle) result (file) class(file_handle_t), intent(in) :: handle type(string_t) :: file file = handle%file end function file_handle_get_file @ %def file_handle_get_file @ For debugging, return the I/O unit number. <>= procedure :: get_unit => file_handle_get_unit <>= module function file_handle_get_unit (handle) result (unit) class(file_handle_t), intent(in) :: handle integer :: unit end function file_handle_get_unit <>= module function file_handle_get_unit (handle) result (unit) class(file_handle_t), intent(in) :: handle integer :: unit unit = handle%unit end function file_handle_get_unit @ %def file_handle_get_unit @ \subsection{File handles registry} This is implemented as a doubly-linked list. The list exists only once in the program, as a private module variable. Extend the handle type to become a list entry: <>= type, extends (file_handle_t) :: file_entry_t type(file_entry_t), pointer :: prev => null () type(file_entry_t), pointer :: next => null () end type file_entry_t @ %def file_entry_t @ The actual registry. We need only the pointer to the first entry. <>= public :: file_registry_t <>= type :: file_registry_t type(file_entry_t), pointer :: first => null () contains <> end type file_registry_t @ %def file_registry_t @ Debugging output. <>= procedure :: write => file_registry_write <>= module subroutine file_registry_write (registry, unit, show_unit) class(file_registry_t), intent(in) :: registry integer, intent(in), optional :: unit logical, intent(in), optional :: show_unit end subroutine file_registry_write <>= module subroutine file_registry_write (registry, unit, show_unit) class(file_registry_t), intent(in) :: registry integer, intent(in), optional :: unit logical, intent(in), optional :: show_unit type(file_entry_t), pointer :: entry integer :: u u = given_output_unit (unit) if (associated (registry%first)) then write (u, "(1x,A)") "File registry:" entry => registry%first do while (associated (entry)) call entry%write (u, show_unit) entry => entry%next end do else write (u, "(1x,A)") "File registry: [empty]" end if end subroutine file_registry_write @ %def file_registry_write @ Open a file: find the appropriate entry. Create a new entry and add to the list if necessary. The list is extended at the beginning. Return the I/O unit number for the records. <>= procedure :: open => file_registry_open <>= module subroutine file_registry_open (registry, file, unit) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file integer, intent(out), optional :: unit end subroutine file_registry_open <>= module subroutine file_registry_open (registry, file, unit) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file integer, intent(out), optional :: unit type(file_entry_t), pointer :: entry entry => registry%first FIND_ENTRY: do while (associated (entry)) if (entry%get_file () == file) exit FIND_ENTRY entry => entry%next end do FIND_ENTRY if (.not. associated (entry)) then allocate (entry) call entry%init (file) if (associated (registry%first)) then registry%first%prev => entry entry%next => registry%first end if registry%first => entry end if call entry%open () if (present (unit)) unit = entry%get_unit () end subroutine file_registry_open @ %def file_registry_open @ Close a file: find the appropriate entry. Delete the entry if there is no file connected to it anymore. <>= procedure :: close => file_registry_close <>= module subroutine file_registry_close (registry, file) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file end subroutine file_registry_close <>= module subroutine file_registry_close (registry, file) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file type(file_entry_t), pointer :: entry entry => registry%first FIND_ENTRY: do while (associated (entry)) if (entry%get_file () == file) exit FIND_ENTRY entry => entry%next end do FIND_ENTRY if (associated (entry)) then call entry%close () if (.not. entry%is_open ()) then if (associated (entry%prev)) then entry%prev%next => entry%next else registry%first => entry%next end if if (associated (entry%next)) then entry%next%prev => entry%prev end if deallocate (entry) end if end if end subroutine file_registry_close @ %def file_registry_close @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{String Utilities} This module provides tools associated with strings (built-in and variable). Currently: \begin{itemize} \item Upper and lower case for strings \item Convert to null-terminated C string \end{itemize} <<[[string_utils.f90]]>>= <> module string_utils use, intrinsic :: iso_c_binding <> <> <> <> <> interface <> end interface end module string_utils @ %def string_utils @ <<[[string_utils_sub.f90]]>>= <> submodule (string_utils) string_utils_s implicit none contains <> end submodule string_utils_s @ %def string_utils_s @ \subsection{Upper and Lower Case} These are, unfortunately, not part of Fortran. <>= public :: upper_case public :: lower_case <>= interface upper_case module procedure upper_case_char, upper_case_string end interface interface lower_case module procedure lower_case_char, lower_case_string end interface <>= module function upper_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string end function upper_case_char module function lower_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string end function lower_case_char module function upper_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string end function upper_case_string module function lower_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string end function lower_case_string <>= module function upper_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string integer :: pos, code integer, parameter :: offset = ichar('A')-ichar('a') do pos = 1, len (string) code = ichar (string(pos:pos)) select case (code) case (ichar('a'):ichar('z')) new_string(pos:pos) = char (code + offset) case default new_string(pos:pos) = string(pos:pos) end select end do end function upper_case_char module function lower_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string integer :: pos, code integer, parameter :: offset = ichar('a')-ichar('A') do pos = 1, len (string) code = ichar (string(pos:pos)) select case (code) case (ichar('A'):ichar('Z')) new_string(pos:pos) = char (code + offset) case default new_string(pos:pos) = string(pos:pos) end select end do end function lower_case_char module function upper_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string new_string = upper_case_char (char (string)) end function upper_case_string module function lower_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string new_string = lower_case_char (char (string)) end function lower_case_string @ %def upper_case lower_case @ \subsection{C-Fortran String Conversion} Convert a FORTRAN string to a null-terminated C string. <>= public :: string_f2c <>= interface string_f2c module procedure string_f2c_char, string_f2c_var_str end interface string_f2c <>= pure module function string_f2c_char (i) result (o) character(*), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o end function string_f2c_char pure module function string_f2c_var_str (i) result (o) type(string_t), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o end function string_f2c_var_str <>= pure module function string_f2c_char (i) result (o) character(*), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o o = i // c_null_char end function string_f2c_char pure module function string_f2c_var_str (i) result (o) type(string_t), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o o = char (i) // c_null_char end function string_f2c_var_str @ %def string_f2c @ The same task done by a subroutine, analogous to the C [[strcpy]] function. We append a null char and copy the characters to the output string, given by a character array -- which is equal to a [[c_char]] character string by the rule of sequence association. Note: Just like with the [[strcpy]] function, there is no bounds check. <>= public :: strcpy_f2c <>= module subroutine strcpy_f2c (fstring, cstring) character(*), intent(in) :: fstring character(c_char), dimension(*), intent(inout) :: cstring end subroutine strcpy_f2c <>= module subroutine strcpy_f2c (fstring, cstring) character(*), intent(in) :: fstring character(c_char), dimension(*), intent(inout) :: cstring integer :: i do i = 1, len (fstring) cstring(i) = fstring(i:i) end do cstring(len(fstring)+1) = c_null_char end subroutine strcpy_f2c @ %def strcpy_f2c @ Convert a null-terminated C string to a Fortran string. The C-string argument is sequence-associated to a one-dimensional array of C characters, where we do not know the dimension. To convert this to a [[string_t]] object, we need to assign it or to wrap it by another [[var_str]] conversion. <>= public :: string_c2f <>= module function string_c2f (cstring) result (fstring) character(c_char), dimension(*), intent(in) :: cstring character(:), allocatable :: fstring end function string_c2f <>= module function string_c2f (cstring) result (fstring) character(c_char), dimension(*), intent(in) :: cstring character(:), allocatable :: fstring integer :: i, n n = 0 do while (cstring(n+1) /= c_null_char) n = n + 1 end do allocate (character(n) :: fstring) do i = 1, n fstring(i:i) = cstring(i) end do end function string_c2f @ %def string_c2f @ \subsection{Number Conversion} Create a string from a number. We use fixed format for the reals and variable format for integers. <>= public :: str <>= interface str module procedure str_log, str_logs, str_int, str_ints, & str_real, str_reals, str_complex, str_complexs end interface <>= module function str_log (l) result (s) logical, intent(in) :: l type(string_t) :: s end function str_log module function str_logs (x) result (s) logical, dimension(:), intent(in) :: x type(string_t) :: s end function str_logs module function str_int (i) result (s) integer, intent(in) :: i type(string_t) :: s end function str_int module function str_ints (x) result (s) integer, dimension(:), intent(in) :: x type(string_t) :: s end function str_ints module function str_real (x) result (s) real(default), intent(in) :: x type(string_t) :: s end function str_real module function str_reals (x) result (s) real(default), dimension(:), intent(in) :: x type(string_t) :: s end function str_reals module function str_complex (x) result (s) complex(default), intent(in) :: x type(string_t) :: s end function str_complex module function str_complexs (x) result (s) complex(default), dimension(:), intent(in) :: x type(string_t) :: s end function str_complexs <>= module function str_log (l) result (s) logical, intent(in) :: l type(string_t) :: s if (l) then s = "True" else s = "False" end if end function str_log module function str_logs (x) result (s) logical, dimension(:), intent(in) :: x <> end function str_logs module function str_int (i) result (s) integer, intent(in) :: i type(string_t) :: s character(32) :: buffer write (buffer, "(I0)") i s = var_str (trim (adjustl (buffer))) end function str_int module function str_ints (x) result (s) integer, dimension(:), intent(in) :: x <> end function str_ints module function str_real (x) result (s) real(default), intent(in) :: x type(string_t) :: s character(32) :: buffer write (buffer, "(ES17.10)") x s = var_str (trim (adjustl (buffer))) end function str_real module function str_reals (x) result (s) real(default), dimension(:), intent(in) :: x <> end function str_reals module function str_complex (x) result (s) complex(default), intent(in) :: x type(string_t) :: s s = str_real (real (x)) // " + i " // str_real (aimag (x)) end function str_complex module function str_complexs (x) result (s) complex(default), dimension(:), intent(in) :: x <> end function str_complexs @ %def str <>= type(string_t) :: s integer :: i s = '[' do i = 1, size(x) - 1 s = s // str(x(i)) // ', ' end do s = s // str(x(size(x))) // ']' @ @ Auxiliary: Read real, integer, string value. <>= public :: read_rval public :: read_ival <>= module function read_rval (s) result (rval) real(default) :: rval type(string_t), intent(in) :: s end function read_rval module function read_ival (s) result (ival) integer :: ival type(string_t), intent(in) :: s end function read_ival <>= module function read_rval (s) result (rval) real(default) :: rval type(string_t), intent(in) :: s character(80) :: buffer buffer = s read (buffer, *) rval end function read_rval module function read_ival (s) result (ival) integer :: ival type(string_t), intent(in) :: s character(80) :: buffer buffer = s read (buffer, *) ival end function read_ival @ %def read_rval read_ival @ \subsection{String splitting} <>= public :: string_contains_word <>= pure module function string_contains_word & (str, word, include_identical) result (val) logical :: val type(string_t), intent(in) :: str, word logical, intent(in), optional :: include_identical end function string_contains_word <>= pure module function string_contains_word & (str, word, include_identical) result (val) logical :: val type(string_t), intent(in) :: str, word type(string_t) :: str_tmp, str_out logical, intent(in), optional :: include_identical logical :: yorn str_tmp = str val = .false. yorn = .false.; if (present (include_identical)) yorn = include_identical if (yorn) val = str == word call split (str_tmp, str_out, word) val = val .or. (str_out /= "") end function string_contains_word @ %def string_contains_word @ Create an array of strings using a separator. <>= public :: split_string <>= pure module subroutine split_string (str, separator, str_array) type(string_t), dimension(:), allocatable, intent(out) :: str_array type(string_t), intent(in) :: str, separator end subroutine split_string <>= pure module subroutine split_string (str, separator, str_array) type(string_t), dimension(:), allocatable, intent(out) :: str_array type(string_t), intent(in) :: str, separator type(string_t) :: str_tmp, str_out integer :: n_str n_str = 0; str_tmp = str do while (string_contains_word (str_tmp, separator)) n_str = n_str + 1 call split (str_tmp, str_out, separator) end do allocate (str_array (n_str)) n_str = 1; str_tmp = str do while (string_contains_word (str_tmp, separator)) call split (str_tmp, str_array (n_str), separator) n_str = n_str + 1 end do end subroutine split_string @ %def split_string @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Format Utilities} This module provides miscellaneous tools associated with formatting and pretty-printing. \begin{itemize} \item Horizontal separator lines in output \item Indenting an output line \item Formatting a number for \TeX\ output. \item Formatting a number for MetaPost output. \item Alternate numeric formats. \end{itemize} <<[[format_utils.f90]]>>= <> module format_utils <> <> <> <> interface <> end interface end module format_utils @ %def format_utils @ <<[[format_utils_sub.f90]]>>= <> submodule (format_utils) format_utils_s use string_utils, only: lower_case use io_units, only: given_output_unit implicit none contains <> end submodule format_utils_s @ %def format_utils_s @ \subsection{Line Output} Write a separator line. <>= public :: write_separator <>= module subroutine write_separator (u, mode) integer, intent(in) :: u integer, intent(in), optional :: mode end subroutine write_separator <>= module subroutine write_separator (u, mode) integer, intent(in) :: u integer, intent(in), optional :: mode integer :: m m = 1; if (present (mode)) m = mode select case (m) case default write (u, "(A)") repeat ("-", 72) case (1) write (u, "(A)") repeat ("-", 72) case (2) write (u, "(A)") repeat ("=", 72) end select end subroutine write_separator @ %def write_separator @ Indent the line with given number of blanks. <>= public :: write_indent <>= module subroutine write_indent (unit, indent) integer, intent(in) :: unit integer, intent(in), optional :: indent end subroutine write_indent <>= module subroutine write_indent (unit, indent) integer, intent(in) :: unit integer, intent(in), optional :: indent if (present (indent)) then write (unit, "(1x,A)", advance="no") repeat (" ", indent) end if end subroutine write_indent @ %def write_indent @ \subsection{Array Output} Write an array of integers. <>= public :: write_integer_array <>= module subroutine write_integer_array (array, unit, n_max, no_skip) integer, intent(in), dimension(:) :: array integer, intent(in), optional :: unit integer, intent(in), optional :: n_max logical, intent(in), optional :: no_skip end subroutine write_integer_array <>= module subroutine write_integer_array (array, unit, n_max, no_skip) integer, intent(in), dimension(:) :: array integer, intent(in), optional :: unit integer, intent(in), optional :: n_max logical, intent(in), optional :: no_skip integer :: u, i, n logical :: yorn u = given_output_unit (unit) yorn = .false.; if (present (no_skip)) yorn = no_skip if (present (n_max)) then n = n_max else n = size (array) end if do i = 1, n if (i < n .or. yorn) then write (u, "(I0, A)", advance = "no") array(i), ", " else write (u, "(I0)") array(i) end if end do end subroutine write_integer_array @ %def write_integer_array @ \subsection{\TeX-compatible Output} Quote underscore characters for use in \TeX\ output. <>= public :: quote_underscore <>= module function quote_underscore (string) result (quoted) type(string_t) :: quoted type(string_t), intent(in) :: string end function quote_underscore <>= module function quote_underscore (string) result (quoted) type(string_t) :: quoted type(string_t), intent(in) :: string type(string_t) :: part type(string_t) :: buffer buffer = string quoted = "" do call split (part, buffer, "_") quoted = quoted // part if (buffer == "") exit quoted = quoted // "\_" end do end function quote_underscore @ %def quote_underscore @ Format a number with $n$ significant digits for use in \TeX\ documents. <>= public :: tex_format <>= module function tex_format (rval, n_digits) result (string) type(string_t) :: string real(default), intent(in) :: rval integer, intent(in) :: n_digits end function tex_format <>= module function tex_format (rval, n_digits) result (string) type(string_t) :: string real(default), intent(in) :: rval integer, intent(in) :: n_digits integer :: e, n, w, d real(default) :: absval real(default) :: mantissa character :: sign character(20) :: format character(80) :: cstr n = min (abs (n_digits), 16) if (rval == 0) then string = "0" else absval = abs (rval) e = int (log10 (absval)) if (rval < 0) then sign = "-" else sign = "" end if select case (e) case (:-3) d = max (n - 1, 0) w = max (d + 2, 2) write (format, "('(F',I0,'.',I0,',A,I0,A)')") w, d mantissa = absval * 10._default ** (1 - e) write (cstr, fmt=format) mantissa, "\times 10^{", e - 1, "}" case (-2:0) d = max (n - e, 1 - e) w = max (d + e + 2, d + 2) write (format, "('(F',I0,'.',I0,')')") w, d write (cstr, fmt=format) absval case (1:2) d = max (n - e - 1, -e, 0) w = max (d + e + 2, d + 2, e + 2) write (format, "('(F',I0,'.',I0,')')") w, d write (cstr, fmt=format) absval case default d = max (n - 1, 0) w = max (d + 2, 2) write (format, "('(F',I0,'.',I0,',A,I0,A)')") w, d mantissa = absval * 10._default ** (- e) write (cstr, fmt=format) mantissa, "\times 10^{", e, "}" end select string = sign // trim (cstr) end if end function tex_format @ %def tex_format @ \subsection{Metapost-compatible Output} Write a number for use in Metapost code: <>= public :: mp_format <>= module function mp_format (rval) result (string) type(string_t) :: string real(default), intent(in) :: rval end function mp_format <>= module function mp_format (rval) result (string) type(string_t) :: string real(default), intent(in) :: rval character(16) :: tmp write (tmp, "(G16.8)") rval string = lower_case (trim (adjustl (trim (tmp)))) end function mp_format @ %def mp_format @ \subsection{Conditional Formatting} Conditional format string, intended for switchable numeric precision. <>= public :: pac_fmt <>= module subroutine pac_fmt (fmt, fmt_orig, fmt_pac, pacify) character(*), intent(in) :: fmt_orig, fmt_pac character(*), intent(out) :: fmt logical, intent(in), optional :: pacify end subroutine pac_fmt <>= module subroutine pac_fmt (fmt, fmt_orig, fmt_pac, pacify) character(*), intent(in) :: fmt_orig, fmt_pac character(*), intent(out) :: fmt logical, intent(in), optional :: pacify logical :: pacified pacified = .false. if (present (pacify)) pacified = pacify if (pacified) then fmt = fmt_pac else fmt = fmt_orig end if end subroutine pac_fmt @ %def pac_fmt @ \subsection{Guard tiny values} This function can be applied if values smaller than $10^{-99}$ would cause an underflow in the output format. We know that Fortran fixed-format can handle this by omitting the exponent letter, but we should expect non-Fortran or Fortran list-directed input, which would fail. We reset such values to $\pm 10^{-99}$, assuming that such tiny values would not matter, except for being non-zero. <>= public :: refmt_tiny <>= elemental module function refmt_tiny (val) result (trunc_val) real(default), intent(in) :: val real(default) :: trunc_val end function refmt_tiny <>= elemental module function refmt_tiny (val) result (trunc_val) real(default), intent(in) :: val real(default) :: trunc_val real(default), parameter :: tiny_val = 1.e-99_default if (val /= 0) then if (abs (val) < tiny_val) then trunc_val = sign (tiny_val, val) else trunc_val = val end if else trunc_val = val end if end function refmt_tiny @ %def refmt_tiny @ \subsection{Compressed output of integer arrays} <>= public :: write_compressed_integer_array <>= module subroutine write_compressed_integer_array (chars, array) character(len=*), intent(out) :: chars integer, intent(in), allocatable, dimension(:) :: array end subroutine write_compressed_integer_array <>= module subroutine write_compressed_integer_array (chars, array) character(len=*), intent(out) :: chars integer, intent(in), allocatable, dimension(:) :: array logical, dimension(:), allocatable :: used character(len=16) :: tmp type(string_t) :: string integer :: i, j, start_chain, end_chain chars = '[none]' string = "" if (allocated (array)) then if (size (array) > 0) then allocate (used (size (array))) used = .false. do i = 1, size (array) if (.not. used(i)) then start_chain = array(i) end_chain = array(i) used(i) = .true. EXTEND: do do j = 1, size (array) if (array(j) == end_chain + 1) then end_chain = array(j) used(j) = .true. cycle EXTEND end if if (array(j) == start_chain - 1) then start_chain = array(j) used(j) = .true. cycle EXTEND end if end do exit end do EXTEND if (end_chain - start_chain > 0) then write (tmp, "(I0,A,I0)") start_chain, "-", end_chain else write (tmp, "(I0)") start_chain end if string = string // trim (tmp) if (any (.not. used)) then string = string // ',' end if end if end do chars = string end if end if chars = adjustr (chars) end subroutine write_compressed_integer_array @ %def write_compressed_integer_array %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Format Definitions} This module provides named integer parameters that specify certain format strings, used for numerical output. <<[[format_defs.f90]]>>= <> module format_defs <> <> end module format_defs @ %def format_defs @ We collect format strings for various numerical output formats here. <>= character(*), parameter, public :: FMT_19 = "ES19.12" character(*), parameter, public :: FMT_18 = "ES18.11" character(*), parameter, public :: FMT_17 = "ES17.10" character(*), parameter, public :: FMT_16 = "ES16.9" character(*), parameter, public :: FMT_15 = "ES15.8" character(*), parameter, public :: FMT_14 = "ES14.7" character(*), parameter, public :: FMT_13 = "ES13.6" character(*), parameter, public :: FMT_12 = "ES12.5" character(*), parameter, public :: FMT_11 = "ES11.4" character(*), parameter, public :: FMT_10 = "ES10.3" @ %def FMT_10 FMT_11 FMT_12 FMT_13 FMT_14 @ %def FMT_15 FMT_16 FMT_17 FMT_18 FMT_19 @ Fixed-point formats for better readability, where appropriate. <>= character(*), parameter, public :: FMF_12 = "F12.9" @ %def FMF_12 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Numeric Utilities} <<[[numeric_utils.f90]]>>= <> module numeric_utils <> <> <> <> <> <> <> interface <> end interface end module numeric_utils @ %def numeric_utils @ <<[[numeric_utils_sub.f90]]>>= <> submodule (numeric_utils) numeric_utils_s use string_utils use constants use format_defs implicit none contains <> end submodule numeric_utils_s @ %def numeric_utils_s @ <>= public :: assert <>= module subroutine assert (unit, ok, description, exit_on_fail) integer, intent(in) :: unit logical, intent(in) :: ok character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail end subroutine assert <>= module subroutine assert (unit, ok, description, exit_on_fail) integer, intent(in) :: unit logical, intent(in) :: ok character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail logical :: ef ef = .false.; if (present (exit_on_fail)) ef = exit_on_fail if (.not. ok) then if (present(description)) then write (unit, "(A)") "* FAIL: " // description else write (unit, "(A)") "* FAIL: Assertion error" end if if (ef) stop 1 end if end subroutine assert @ %def assert @ Compare numbers and output error message if not equal. <>= public:: assert_equal interface assert_equal module procedure assert_equal_integer, assert_equal_integers, & assert_equal_real, assert_equal_reals, & assert_equal_complex, assert_equal_complexs end interface @ <>= module subroutine assert_equal_integer (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_integer <>= module subroutine assert_equal_integer (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = lhs == rhs desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_integer @ %def assert_equal_integer @ <>= module subroutine assert_equal_integers (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_integers <>= module subroutine assert_equal_integers (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = all(lhs == rhs) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_integers @ %def assert_equal_integers @ <>= module subroutine assert_equal_real (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_real <>= module subroutine assert_equal_real (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = nearly_equal (lhs, rhs, abs_smallness, rel_smallness) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_real @ %def assert_equal_real @ <>= module subroutine assert_equal_reals (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_reals <>= module subroutine assert_equal_reals (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = all(nearly_equal (lhs, rhs, abs_smallness, rel_smallness)) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_reals @ %def assert_equal_reals @ <>= module subroutine assert_equal_complex (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_complex <>= module subroutine assert_equal_complex (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = nearly_equal (real(lhs), real(rhs), abs_smallness, rel_smallness) & .and. nearly_equal (aimag(lhs), aimag(rhs), abs_smallness, rel_smallness) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_complex @ %def assert_equal_complex @ <>= module subroutine assert_equal_complexs (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_complexs <>= module subroutine assert_equal_complexs (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = all (nearly_equal (real(lhs), real(rhs), abs_smallness, rel_smallness)) & .and. all (nearly_equal (aimag(lhs), aimag(rhs), abs_smallness, rel_smallness)) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_complexs @ %def assert_equal_complexs @ Note that this poor man's check will be disabled if someone compiles with [[-ffast-math]] or similar optimizations. <>= elemental function ieee_is_nan (x) result (yorn) logical :: yorn real(default), intent(in) :: x yorn = (x /= x) end function ieee_is_nan @ %def ieee_is_nan @ This is still not perfect but should work in most cases. Usually one wants to compare to a relative epsilon [[rel_smallness]], except for numbers close to zero defined by [[abs_smallness]]. Both might need adaption to specific use cases but have reasonable defaults. <>= public :: nearly_equal <>= interface nearly_equal module procedure nearly_equal_real module procedure nearly_equal_complex end interface nearly_equal <>= elemental module function nearly_equal_real & (a, b, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness end function nearly_equal_real <>= elemental module function nearly_equal_real & (a, b, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness real(default) :: abs_a, abs_b, diff, abs_small, rel_small abs_a = abs (a) abs_b = abs (b) diff = abs (a - b) ! shortcut, handles infinities and nans if (a == b) then r = .true. return else if (ieee_is_nan (a) .or. ieee_is_nan (b) .or. ieee_is_nan (diff)) then r = .false. return end if abs_small = tiny_13; if (present (abs_smallness)) abs_small = abs_smallness rel_small = tiny_10; if (present (rel_smallness)) rel_small = rel_smallness if (abs_a < abs_small .and. abs_b < abs_small) then r = diff < abs_small else r = diff / max (abs_a, abs_b) < rel_small end if end function nearly_equal_real @ %def nearly_equal_real <>= elemental module function nearly_equal_complex & (a, b, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness end function nearly_equal_complex <>= elemental module function nearly_equal_complex & (a, b, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness r = nearly_equal_real (real (a), real (b), abs_smallness, rel_smallness) .and. & nearly_equal_real (aimag (a), aimag(b), abs_smallness, rel_smallness) end function nearly_equal_complex @ %def neary_equal_complex @ Often we will need to check whether floats vanish: <>= public:: vanishes interface vanishes module procedure vanishes_real, vanishes_complex end interface @ <>= elemental module function vanishes_real & (x, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness end function vanishes_real elemental module function vanishes_complex & (x, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness end function vanishes_complex <>= elemental module function vanishes_real & (x, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness r = nearly_equal (x, zero, abs_smallness, rel_smallness) end function vanishes_real elemental module function vanishes_complex & (x, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness r = vanishes_real (abs (x), abs_smallness, rel_smallness) end function vanishes_complex @ %def vanishes @ <>= public :: expanded_amp2 <>= pure module function expanded_amp2 (amp_tree, amp_blob) result (amp2) real(default) :: amp2 complex(default), dimension(:), intent(in) :: amp_tree, amp_blob end function expanded_amp2 <>= pure module function expanded_amp2 (amp_tree, amp_blob) result (amp2) real(default) :: amp2 complex(default), dimension(:), intent(in) :: amp_tree, amp_blob amp2 = sum (amp_tree * conjg (amp_tree) + & amp_tree * conjg (amp_blob) + & amp_blob * conjg (amp_tree)) end function expanded_amp2 @ %def expanded_amp2 @ <>= public :: abs2 <>= elemental module function abs2 (c) result (c2) real(default) :: c2 complex(default), intent(in) :: c end function abs2 <>= elemental module function abs2 (c) result (c2) real(default) :: c2 complex(default), intent(in) :: c c2 = real (c * conjg(c)) end function abs2 @ %def abs2 @ Remove element with [[index]] from array <>= public:: remove_array_element interface remove_array_element module procedure remove_array_element_logical end interface @ <>= module function remove_array_element_logical & (array, index) result (array_reduced) logical, intent(in), dimension(:) :: array integer, intent(in) :: index logical, dimension(:), allocatable :: array_reduced end function remove_array_element_logical <>= module function remove_array_element_logical & (array, index) result (array_reduced) logical, intent(in), dimension(:) :: array integer, intent(in) :: index logical, dimension(:), allocatable :: array_reduced integer :: i allocate (array_reduced(0)) do i = 1, size (array) if (i /= index) then array_reduced = [array_reduced, [array(i)]] end if end do end function remove_array_element_logical @ %def remove_array_element @ Remove all duplicates from an array of signed integers and returns an unordered array of remaining elements. This method does not really fit into this module. It could be part of a larger module which deals with array manipulations. <>= public :: remove_duplicates_from_int_array <>= module function remove_duplicates_from_int_array & (array) result (array_unique) integer, intent(in), dimension(:) :: array integer, dimension(:), allocatable :: array_unique end function remove_duplicates_from_int_array <>= module function remove_duplicates_from_int_array & (array) result (array_unique) integer, intent(in), dimension(:) :: array integer, dimension(:), allocatable :: array_unique integer :: i allocate (array_unique(0)) do i = 1, size (array) if (any (array_unique == array(i))) cycle array_unique = [array_unique, [array(i)]] end do end function remove_duplicates_from_int_array @ %def remove_duplicates_from_int_array @ <>= public :: extend_integer_array <>= module subroutine extend_integer_array (list, incr, initial_value) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: incr integer, intent(in), optional :: initial_value end subroutine extend_integer_array <>= module subroutine extend_integer_array (list, incr, initial_value) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: incr integer, intent(in), optional :: initial_value integer, dimension(:), allocatable :: list_store integer :: n, ini ini = 0; if (present (initial_value)) ini = initial_value n = size (list) allocate (list_store (n)) list_store = list deallocate (list) allocate (list (n+incr)) list(1:n) = list_store list(1+n : n+incr) = ini deallocate (list_store) end subroutine extend_integer_array @ %def extend_integer_array @ <>= public :: crop_integer_array <>= module subroutine crop_integer_array (list, i_crop) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: i_crop end subroutine crop_integer_array <>= module subroutine crop_integer_array (list, i_crop) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: i_crop integer, dimension(:), allocatable :: list_store allocate (list_store (i_crop)) list_store = list(1:i_crop) deallocate (list) allocate (list (i_crop)) list = list_store deallocate (list_store) end subroutine crop_integer_array @ %def crop_integer_array @ We also need an evaluation of $\log x$ which is stable near $x=1$. <>= public :: log_prec <>= module function log_prec (x, xb) result (lx) real(default), intent(in) :: x, xb real(default) :: lx end function log_prec <>= module function log_prec (x, xb) result (lx) real(default), intent(in) :: x, xb real(default) :: a1, a2, a3, lx a1 = xb a2 = a1 * xb / two a3 = a2 * xb * two / three if (abs (a3) < epsilon (a3)) then lx = - a1 - a2 - a3 else lx = log (x) end if end function log_prec @ %def log_prec @ <>= public :: split_array <>= interface split_array module procedure split_integer_array module procedure split_real_array end interface <>= module subroutine split_integer_array (list1, list2) integer, intent(inout), dimension(:), allocatable :: list1, list2 integer, dimension(:), allocatable :: list_store end subroutine split_integer_array module subroutine split_real_array (list1, list2) real(default), intent(inout), dimension(:), allocatable :: list1, list2 real(default), dimension(:), allocatable :: list_store end subroutine split_real_array <>= module subroutine split_integer_array (list1, list2) integer, intent(inout), dimension(:), allocatable :: list1, list2 integer, dimension(:), allocatable :: list_store allocate (list_store (size (list1) - size (list2))) list2 = list1(:size (list2)) list_store = list1 (size (list2) + 1:) deallocate (list1) allocate (list1 (size (list_store))) list1 = list_store deallocate (list_store) end subroutine split_integer_array module subroutine split_real_array (list1, list2) real(default), intent(inout), dimension(:), allocatable :: list1, list2 real(default), dimension(:), allocatable :: list_store allocate (list_store (size (list1) - size (list2))) list2 = list1(:size (list2)) list_store = list1 (size (list2) + 1:) deallocate (list1) allocate (list1 (size (list_store))) list1 = list_store deallocate (list_store) end subroutine split_real_array @ %def split_array @ +\subsection{Suppression of numerical noise} +<>= + public :: pacify +<>= + interface pacify + module procedure pacify_real_default + module procedure pacify_complex_default + end interface pacify + +<>= + elemental module subroutine pacify_real_default (x, tolerance) + real(default), intent(inout) :: x + real(default), intent(in) :: tolerance + end subroutine pacify_real_default + + elemental module subroutine pacify_complex_default (x, tolerance) + complex(default), intent(inout) :: x + real(default), intent(in) :: tolerance + end subroutine pacify_complex_default +<>= + elemental module subroutine pacify_real_default (x, tolerance) + real(default), intent(inout) :: x + real(default), intent(in) :: tolerance + if (abs (x) < tolerance) x = 0._default + end subroutine pacify_real_default + + elemental module subroutine pacify_complex_default (x, tolerance) + complex(default), intent(inout) :: x + real(default), intent(in) :: tolerance + if (abs (real (x)) < tolerance) & + x = cmplx (0._default, aimag (x), kind=default) + if (abs (aimag (x)) < tolerance) & + x = cmplx (real (x), 0._default, kind=default) + end subroutine pacify_complex_default + +@ %def pacify +@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Binary Tree} <<[[binary_tree.f90]]>>= <> module binary_tree <> <> <> interface <> end interface contains <> end module binary_tree @ %def binary_tree @ <<[[binary_tree_sub.f90]]>>= <> submodule (binary_tree) binary_tree_s use io_units implicit none contains <> end submodule binary_tree_s @ %def binary_tree_s @ <>= public :: binary_tree_iterator_t <>= type :: binary_tree_iterator_t integer, dimension(:), allocatable :: key integer :: current !! current \in {1, N}. contains <> end type binary_tree_iterator_t @ %def binary_tree_iterator_t @ <>= type :: binary_tree_node_t integer :: height = 0 type(binary_tree_node_t), pointer :: left => null () type(binary_tree_node_t), pointer :: right => null () !! integer :: key = 0 class(*), pointer :: obj => null () contains <> end type binary_tree_node_t @ %def binary_tree_node_t @ <>= public :: binary_tree_t <>= type :: binary_tree_t integer :: n_elements = 0 type(binary_tree_node_t), pointer :: root => null () contains <> end type binary_tree_t @ %def binary_tree_t @ <>= procedure :: init => binary_tree_iterator_init <>= module subroutine binary_tree_iterator_init (iterator, btree) class(binary_tree_iterator_t), intent(inout) :: iterator type(binary_tree_t), target :: btree end subroutine binary_tree_iterator_init <>= !! We store all keys of the binary tree in an index array. !! Flatten the tree O(log n), each access is then O(1). !! However, accessing the corresponding object costs one O(log n). module subroutine binary_tree_iterator_init (iterator, btree) class(binary_tree_iterator_t), intent(inout) :: iterator type(binary_tree_t), target :: btree type(binary_tree_node_t), pointer :: node integer :: idx iterator%current = 1 allocate (iterator%key(btree%get_n_elements ()), source = 0) if (.not. btree%get_n_elements () > 0) return idx = 1; call fill_key (idx, iterator%key, btree%root) contains recursive subroutine fill_key (idx, key, node) integer, intent(inout) :: idx integer, dimension(:), intent(inout) :: key type(binary_tree_node_t), pointer :: node if (associated (node%left)) & call fill_key (idx, key, node%left) key(idx) = node%key idx = idx + 1 if (associated (node%right)) & call fill_key (idx, key, node%right) end subroutine fill_key end subroutine binary_tree_iterator_init @ %def binary_tree_iterator_init @ <>= procedure :: is_iterable => binary_tree_iterator_is_iterable <>= module function binary_tree_iterator_is_iterable (iterator) result (flag) class(binary_tree_iterator_t), intent(in) :: iterator logical :: flag end function binary_tree_iterator_is_iterable <>= module function binary_tree_iterator_is_iterable (iterator) result (flag) class(binary_tree_iterator_t), intent(in) :: iterator logical :: flag flag = iterator%current <= size (iterator%key) end function binary_tree_iterator_is_iterable @ %def binary_tree_iterator_is_handle @ <>= procedure :: next => binary_tree_iterator_next <>= module subroutine binary_tree_iterator_next (iterator, key) class(binary_tree_iterator_t), intent(inout) :: iterator integer, intent(out) :: key end subroutine binary_tree_iterator_next <>= module subroutine binary_tree_iterator_next (iterator, key) class(binary_tree_iterator_t), intent(inout) :: iterator integer, intent(out) :: key if (.not. iterator%is_iterable ()) then key = 0 else key = iterator%key(iterator%current) iterator%current = iterator%current + 1 end if end subroutine binary_tree_iterator_next @ %def binary_tree_iterator_next @ <>= procedure :: init => binary_tree_node_init <>= module subroutine binary_tree_node_init (btree_node, key, obj) class(binary_tree_node_t), intent(inout) :: btree_node integer, intent(in) :: key class(*), pointer :: obj end subroutine binary_tree_node_init <>= module subroutine binary_tree_node_init (btree_node, key, obj) class(binary_tree_node_t), intent(inout) :: btree_node integer, intent(in) :: key class(*), pointer :: obj btree_node%height = 1 btree_node%left => null () btree_node%right => null () btree_node%key = key btree_node%obj => obj end subroutine binary_tree_node_init @ %def binary_tree_node_init @ <>= procedure :: write => binary_tree_node_write <>= recursive module subroutine binary_tree_node_write & (btree_node, unit, level, mode) class(binary_tree_node_t), intent(in) :: btree_node integer, intent(in) :: unit integer, intent(in) :: level character(len=*), intent(in) :: mode end subroutine binary_tree_node_write <>= recursive module subroutine binary_tree_node_write & (btree_node, unit, level, mode) class(binary_tree_node_t), intent(in) :: btree_node integer, intent(in) :: unit integer, intent(in) :: level character(len=*), intent(in) :: mode character(len=24) :: fmt if (level > 0) then write (fmt, "(A,I3,A)") "(", 3 * level, "X,A,1X,I3,1X,I3,A)" else fmt = "(A,1X,I3,1X,I3,1X)" end if write (unit, fmt) mode, btree_node%key, btree_node%height ! write (unit, fmt) btree_node%key, btree_node%get_balance () if (associated (btree_node%right)) & call btree_node%right%write (unit, level = level + 1, mode = ">") if (associated (btree_node%left)) & call btree_node%left%write (unit, level = level + 1, mode = "<") end subroutine binary_tree_node_write @ %def binary_tree_node_write @ <>= procedure :: get_balance => binary_tree_node_get_balance <>= module function binary_tree_node_get_balance (btree_node) result (balance) class(binary_tree_node_t), intent(in) :: btree_node integer :: balance end function binary_tree_node_get_balance <>= module function binary_tree_node_get_balance (btree_node) result (balance) class(binary_tree_node_t), intent(in) :: btree_node integer :: balance integer :: leftHeight, rightHeight leftHeight = 0 rightHeight = 0 if (associated (btree_node%left)) leftHeight = btree_node%left%height if (associated (btree_node%right)) rightHeight = btree_node%right%height balance = leftHeight - rightHeight end function binary_tree_node_get_balance @ %def binary_tree_node_get_balance @ <>= procedure :: increment_height => binary_tree_node_increment_height <>= module subroutine binary_tree_node_increment_height (btree_node) class(binary_tree_node_t), intent(inout) :: btree_node end subroutine binary_tree_node_increment_height <>= module subroutine binary_tree_node_increment_height (btree_node) class(binary_tree_node_t), intent(inout) :: btree_node integer :: leftHeight, rightHeight leftHeight = 0 rightHeight = 0 if (associated (btree_node%left)) leftHeight = btree_node%left%height if (associated (btree_node%right)) rightHeight = btree_node%right%height btree_node%height = max (leftHeight, rightHeight) + 1 end subroutine binary_tree_node_increment_height @ %def binary_tree_node_increment_height @ <>= final :: binary_tree_node_final <>= !!! !!! NAG 7 compiler bug with finalizers and unlimited polymorphism !!! module subroutine binary_tree_node_final (btree_node) !!! type(binary_tree_node_t), intent(inout) :: btree_node !!! end subroutine binary_tree_node_final <>= recursive subroutine binary_tree_node_final (btree_node) type(binary_tree_node_t), intent(inout) :: btree_node if (associated (btree_node%left)) deallocate (btree_node%left) if (associated (btree_node%right)) deallocate (btree_node%right) deallocate (btree_node%obj) end subroutine binary_tree_node_final @ %def binary_tree_node_final @ <>= procedure :: write => binary_tree_write <>= module subroutine binary_tree_write (btree, unit) class(binary_tree_t), intent(in) :: btree integer, intent(in), optional :: unit end subroutine binary_tree_write <>= module subroutine binary_tree_write (btree, unit) class(binary_tree_t), intent(in) :: btree integer, intent(in), optional :: unit integer :: u u = given_output_unit(unit=unit) write (u, "(A,1X,I3)") "Number of elements", btree%n_elements if (associated (btree%root)) then call btree%root%write (u, level = 0, mode = "*") else write (u, "(A)") "Binary tree is empty." end if end subroutine binary_tree_write @ %def binary_tree_write @ <>= final :: binary_tree_final <>= !!! !!! NAG 7 compiler bug with finalizers and unlimited polymorphism !!! module subroutine binary_tree_final (btree) !!! type(binary_tree_t), intent(inout) :: btree !!! end subroutine binary_tree_final <>= subroutine binary_tree_final (btree) type(binary_tree_t), intent(inout) :: btree btree%n_elements = 0 if (associated (btree%root)) then deallocate (btree%root) end if end subroutine binary_tree_final @ %def binary_tree_final @ <>= procedure :: clear => binary_tree_clear <>= module subroutine binary_tree_clear (btree) class(binary_tree_t), intent(inout) :: btree end subroutine binary_tree_clear <>= module subroutine binary_tree_clear (btree) class(binary_tree_t), intent(inout) :: btree call binary_tree_final (btree) end subroutine binary_tree_clear @ %def binary_tree_clear @ <>= procedure :: get_n_elements => binary_tree_get_n_elements <>= module function binary_tree_get_n_elements (btree) result (n) class(binary_tree_t), intent(in) :: btree integer :: n end function binary_tree_get_n_elements <>= module function binary_tree_get_n_elements (btree) result (n) class(binary_tree_t), intent(in) :: btree integer :: n n = btree%n_elements end function binary_tree_get_n_elements @ %def binary_tree_get_n_elements @ <>= procedure :: insert => binary_tree_insert <>= module subroutine binary_tree_insert (btree, key, obj) class(binary_tree_t), intent(inout) :: btree integer, intent(in) :: key class(*), pointer, intent(in) :: obj end subroutine binary_tree_insert <>= module subroutine binary_tree_insert (btree, key, obj) class(binary_tree_t), intent(inout) :: btree integer, intent(in) :: key class(*), pointer, intent(in) :: obj type(binary_tree_node_t), pointer :: node allocate (node) call node%init (key, obj) btree%n_elements = btree%n_elements + 1 if (.not. associated (btree%root)) then btree%root => node else call btree%insert_node (btree%root, node) end if end subroutine binary_tree_insert @ %def binary_tree_import @ <>= procedure, private :: insert_node => binary_tree_insert_node <>= recursive module subroutine binary_tree_insert_node (btree, parent, node) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: parent type(binary_tree_node_t), intent(in), pointer :: node end subroutine binary_tree_insert_node <>= recursive module subroutine binary_tree_insert_node (btree, parent, node) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: parent type(binary_tree_node_t), intent(in), pointer :: node !! Choose left or right, if associated descend recursively into subtree, !! else insert node. if (node%key > parent%key) then if (associated (parent%right)) then call btree%insert_node (parent%right, node) else parent%right => node end if else if (node%key < parent%key) then if (associated (parent%left)) then call btree%insert_node (parent%left, node) else parent%left => node end if else write (*, "(A,1X,I0)") "Error: MUST not insert duplicate key", node%key stop 1 end if call parent%increment_height () call btree%balance (parent, node%key) end subroutine binary_tree_insert_node @ %def binary_tree_insert_node @ <>= procedure, private :: balance => binary_tree_balance <>= module subroutine binary_tree_balance (btree, subtree, key) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: subtree integer, intent(in) :: key end subroutine binary_tree_balance <>= !! Subtree: root of subtree (which is unbalance, refer to A in diagrams.) module subroutine binary_tree_balance (btree, subtree, key) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: subtree integer, intent(in) :: key type(binary_tree_node_t), pointer :: node, newNode integer :: balance balance = subtree%get_balance () node => subtree newNode => null () !! balance := h_left - h_right. !! Proof: balance > 0 => too many elements on the left side of the subtree. !! Proof: balance < 0 => too many elements on the right side of the subtree. if (balance > 1) then !! => left-side of subtree !! A3(2) B2(1) !! / / \ !! B2(1) C1(0) A1(0) !! / !! C1(0) !! !! A3(3) A1(2) C2(1) !! / / / \ !! B1(1) LEFT C2(1) RIGHT B1(0) A3(0) !! \ / !! C2(0) B1(0) if (subtree%left%key > key) then !! rotate right call btree%rotate_right (node, newNode) else !! subtree%left%key < key, rotate left, then right. call btree%rotate_left (node%left, newNode) node%left => newNode call btree%rotate_right (node, newNode) end if else if (balance < -1) then !! => right-side of subtree !! A0(2) B1(1) !! \ / \ !! B1(1) A1(0) C3(0) !! \ !! C3(0)* !! !! A1(2) A1(2) C2(1) !! \ \ / \ !! B3(1) RIGHT C2(1) LEFT A1(0) B3(0) !! / \ !! C2(0) B3(0) if (subtree%right%key < key) then !! rotate left call btree%rotate_left (node, newNode) else !! subtree%right%key > key, rotate right, then left. call btree%rotate_right (node%right, newNode) node%right => newNode call btree%rotate_left (node, newNode) end if end if if (associated (newNode)) subtree => newNode end subroutine binary_tree_balance @ %def binary_tree_balance @ <>= procedure :: search => binary_tree_search <>= module subroutine binary_tree_search (btree, key, obj) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key class(*), pointer, intent(out) :: obj end subroutine binary_tree_search <>= module subroutine binary_tree_search (btree, key, obj) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key class(*), pointer, intent(out) :: obj type(binary_tree_node_t), pointer :: current current => btree%root obj => null () if (.not. associated (current)) return do while (current%key /= key) if (current%key > key) then current => current%left else current => current%right end if if (.not. associated (current)) then !! Key not found. exit end if end do if (associated (current)) obj => current%obj end subroutine binary_tree_search @ %def binary_tree_search @ <>= procedure :: has_key => binary_tree_has_key <>= module function binary_tree_has_key (btree, key) result (flag) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key logical :: flag end function binary_tree_has_key <>= module function binary_tree_has_key (btree, key) result (flag) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key logical :: flag type(binary_tree_node_t), pointer :: current current => btree%root flag = .false. if (.not. associated (current)) return do while (current%key /= key) if (current%key > key) then current => current%left else current => current%right end if if (.not. associated (current)) then !! Key not found. return end if end do flag = .true. end function binary_tree_has_key @ %def binary_tree_has_key @ <>= procedure, private :: rotate_right => binary_tree_rotate_right <>= module subroutine binary_tree_rotate_right (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root end subroutine binary_tree_rotate_right <>= !! A Move B to A. !! / \ !! B E 1. Split B from A%left. !! / \ 2. Temporarily pointer to D. !! C D 3. Replace pointer to D by pointer to A - E. !! 4. Set temporary pointer to D to A%left. !! !! 1.+2. B T => D A !! / \ !! C E !! !! 3. B T => D !! / \ !! C A !! \ !! E !! !! 4. B !! / \ !! C A !! / \ !! D E !! !! \param[inout] root Root/parent root (A). !! \param[out] new_root New root/parent root (B). module subroutine binary_tree_rotate_right (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root type(binary_tree_node_t), pointer :: tmp new_root => root%left tmp => new_root%right new_root%right => root root%left => tmp call root%increment_height () call new_root%increment_height () end subroutine binary_tree_rotate_right @ %def binary_tree_rotate_right @ <>= procedure, private :: rotate_left => binary_tree_rotate_left <>= module subroutine binary_tree_rotate_left (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root end subroutine binary_tree_rotate_left <>= !! A Move B to A. !! / \ !! E B 1. Split B from A%left. !! / \ 2. Temporarily pointer to C. !! C D 3. Replace pointer to C by pointer to A - E. !! 4. Set temporary pointer to C to A%right. !! !! 1.+2. B T => C A !! \ / !! D E !! !! 3. B T => C !! / \ !! A D !! / !! E !! !! 4. B !! / \ !! A D !! / \ !! E C module subroutine binary_tree_rotate_left (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root type(binary_tree_node_t), pointer :: tmp new_root => root%right tmp => new_root%left new_root%left => root root%right => tmp call root%increment_height () call new_root%increment_height () end subroutine binary_tree_rotate_left @ %def binary_tree_rotate_left @ \subsection{Unit tests} \label{sec:unit-tests} <<[[binary_tree_ut.f90]]>>= <> module binary_tree_ut use unit_tests use binary_tree_uti <> <> contains <> end module binary_tree_ut @ %def binary_tree_ut @ <<[[binary_tree_uti.f90]]>>= <> module binary_tree_uti use binary_tree <> type :: btree_obj_t integer :: i = 0 end type btree_obj_t <> contains <> end module binary_tree_uti @ %def binary_tree_uti @ <>= public :: binary_tree_test <>= subroutine binary_tree_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine binary_tree_test @ %def binary_tree_test @ Provide testing for interface stability and correct implementation for the binary tree and its iterator. <>= call test (binary_tree_1, "binary_tree_1", & "check interface and implementation", & u, results) <>= public :: binary_tree_1 <>= subroutine binary_tree_1 (u) integer, intent(in) :: u integer, dimension(10) :: ndx = [1, 2, 5, 7, 19, 23, 97, -1, -6, 0] class(*), pointer :: obj type(binary_tree_t) :: btree type(binary_tree_iterator_t) :: iterator integer :: i, key write (u, "(A)") "* Test outout: Binary tree" write (u, "(A)") "* Purpose: test interface and implementation of binary tree " // & "and its iterator using polymorph objects." write (u, "(A)") write (u, "(A)") "* Insert fixed number of object into tree..." do i = 1, size (ndx) call allocate_obj (i, obj) call btree%insert (ndx(i), obj) end do write (u, "(A)") "* Search for all added objects in tree..." do i = size (ndx), 1, -1 write (u, "(A,1X,I3,1X,L1)") "- Has key", ndx(i), btree%has_key (ndx(i)) call btree%search (ndx(i), obj) select type (obj) type is (btree_obj_t) write (u, "(2(A,1X,I3,1X))") "- NDX", ndx(i), "OBJ", obj%i end select end do write (u, "(A)") "* Output binary tree in preorder..." call btree%write (u) write (u, "(A)") "* Clear binary tree..." call btree%clear () call btree%write (u) write (u, "(A)") "* Insert fixed number of object into tree (reversed order)..." do i = size (ndx), 1, -1 call allocate_obj (i, obj) call btree%insert (ndx(i), obj) end do write (u, "(A)") "* Iterate over binary tree..." call iterator%init (btree) do while (iterator%is_iterable ()) call iterator%next (key) call btree%search (key, obj) select type (obj) type is (btree_obj_t) write (u, "(2(A,1X,I3,1X))") "- KEY", key, "OBJ", obj%i end select end do write (u, "(A)") "* Search for a non-existing key..." write (u, "(A,1X,I3,1X,L1)") "- Has key", 123, btree%has_key (123) call btree%search (123, obj) write (u, "(A,1X,L1)") "- Object found", associated (obj) !! Do not test against a duplicate entry as the it will forcibly stop the program. contains subroutine allocate_obj (num, obj) integer, intent(in) :: num class(*), pointer, intent(out) :: obj allocate (btree_obj_t :: obj) select type (obj) type is (btree_obj_t) obj%i = num end select end subroutine allocate_obj end subroutine binary_tree_1 @ %def binary_tree_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Array List} <<[[array_list.f90]]>>= <> module array_list <> <> <> <> <> interface <> end interface end module array_list @ %def array_list @ <<[[array_list_sub.f90]]>>= <> submodule (array_list) array_list_s use, intrinsic :: iso_fortran_env, only: ERROR_UNIT use io_units implicit none contains <> end submodule array_list_s @ %def array_list_s @ <>= integer, parameter :: ARRAY_LIST_START_SIZE = 10 real(default), parameter :: ARRAY_LIST_GROW_FACTOR = 1.5_default, & ARRAY_LIST_SHRINK_THRESHOLD = 0.3_default @ %def array_list_start_size array_list_grow_factor @ %def array_list_shrink_threshold @ <>= public :: array_list_t <>= type :: array_list_t private integer, dimension(:), allocatable :: array !! Track the index to *current* item, to be stored. !! Must fulfill: 0 <= count <= size. integer :: count = 0 !! size \in N. integer :: size = 0 contains <> end type array_list_t @ %def array_list_t @ <>= procedure :: write => array_list_write <>= module subroutine array_list_write (list, unit) class(array_list_t), intent(in) :: list integer, intent(in), optional :: unit end subroutine array_list_write <>= module subroutine array_list_write (list, unit) class(array_list_t), intent(in) :: list integer, intent(in), optional :: unit integer :: u u = ERROR_UNIT; if (present (unit)) u = unit write (u, "(A,2(1X,I3))") "COUNT / SIZE", list%count, list%size write (u, "(999(1X,I4))") list%array end subroutine array_list_write @ %def array_list_write @ <>= procedure :: init => array_list_init <>= module subroutine array_list_init (list) class(array_list_t), intent(out) :: list end subroutine array_list_init <>= module subroutine array_list_init (list) class(array_list_t), intent(out) :: list allocate (list%array(ARRAY_LIST_START_SIZE), source = 0) list%count = 0 list%size = ARRAY_LIST_START_SIZE end subroutine array_list_init @ %def array_list_init @ <>= procedure :: get => array_list_get <>= elemental module function array_list_get (list, index) result (data) class(array_list_t), intent(in) :: list integer, intent(in) :: index integer :: data end function array_list_get <>= elemental module function array_list_get (list, index) result (data) class(array_list_t), intent(in) :: list integer, intent(in) :: index integer :: data if (list%is_index (index)) then data = list%array(index) else data = 0 end if end function array_list_get @ %def array_list_get @ <>= procedure :: get_count => array_list_get_count <>= pure module function array_list_get_count (list) result (count) class(array_list_t), intent(in) :: list integer :: count end function array_list_get_count <>= pure module function array_list_get_count (list) result (count) class(array_list_t), intent(in) :: list integer :: count count = list%count end function array_list_get_count @ %def array_list_get_count @ <>= procedure :: get_size => array_list_get_size <>= pure module function array_list_get_size (list) result (size) class(array_list_t), intent(in) :: list integer :: size end function array_list_get_size <>= pure module function array_list_get_size (list) result (size) class(array_list_t), intent(in) :: list integer :: size size = list%size end function array_list_get_size @ %def array_list_get_size @ <>= procedure :: is_full => array_list_is_full <>= pure module function array_list_is_full (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag end function array_list_is_full <>= pure module function array_list_is_full (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag flag = list%count >= list%size end function array_list_is_full @ %def array_list_is_full @ <>= procedure :: is_empty => array_list_is_empty <>= pure module function array_list_is_empty (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag end function array_list_is_empty <>= pure module function array_list_is_empty (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag flag = .not. list%count > 0 end function array_list_is_empty @ %def array_list_is_empty @ <>= procedure :: is_index => array_list_is_index <>= pure module function array_list_is_index (list, index) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: index logical :: flag end function array_list_is_index <>= pure module function array_list_is_index (list, index) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: index logical :: flag flag = 0 < index .and. index <= list%count end function array_list_is_index @ %def array_list_is_index @ <>= procedure :: clear => array_list_clear <>= module subroutine array_list_clear (list) class(array_list_t), intent(inout) :: list end subroutine array_list_clear <>= module subroutine array_list_clear (list) class(array_list_t), intent(inout) :: list list%array = 0 list%count = 0 call list%shrink_size () end subroutine array_list_clear @ %def array_list_clear @ <>= procedure :: add => array_list_add <>= module subroutine array_list_add (list, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: data end subroutine array_list_add <>= module subroutine array_list_add (list, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: data list%count = list%count + 1 if (list%is_full ()) then call list%grow_size () end if list%array(list%count) = data end subroutine array_list_add @ %def array_list_add @ <>= procedure :: grow_size => array_list_grow_size <>= module subroutine array_list_grow_size (list) class(array_list_t), intent(inout) :: list end subroutine array_list_grow_size <>= module subroutine array_list_grow_size (list) class(array_list_t), intent(inout) :: list integer, dimension(:), allocatable :: array integer :: new_size if (.not. list%is_full ()) return new_size = int (list%size * ARRAY_LIST_GROW_FACTOR) allocate (array(new_size), source = 0) array(:list%size) = list%array call move_alloc (array, list%array) list%size = size (list%array) end subroutine array_list_grow_size @ %def array_list_grow_size @ <>= procedure :: shrink_size => array_list_shrink_size <>= module subroutine array_list_shrink_size (list) class(array_list_t), intent(inout) :: list integer, dimension(:), allocatable :: array end subroutine array_list_shrink_size <>= module subroutine array_list_shrink_size (list) class(array_list_t), intent(inout) :: list integer, dimension(:), allocatable :: array integer :: new_size !! Apply shrink threshold on count. ! if (.not. list%count > 0) return new_size = max (list%count, ARRAY_LIST_START_SIZE) allocate (array(new_size), source = 0) !! \note We have to circumvent the allocate-on-assignment, !! hence, we explicitly set the array boundaries. array(:list%count) = list%array(:list%count) call move_alloc (array, list%array) list%size = new_size end subroutine array_list_shrink_size @ %def array_list_shrink_size @ <>= procedure :: reverse_order => array_list_reverse_order <>= module subroutine array_list_reverse_order (list) class(array_list_t), intent(inout) :: list end subroutine array_list_reverse_order <>= module subroutine array_list_reverse_order (list) class(array_list_t), intent(inout) :: list list%array(:list%count) = list%array(list%count:1:-1) end subroutine array_list_reverse_order @ %def array_list_reverse_order @ <>= procedure :: sort => array_list_sort <>= pure module subroutine array_list_sort (list) class(array_list_t), intent(inout) :: list end subroutine array_list_sort <>= pure module subroutine array_list_sort (list) class(array_list_t), intent(inout) :: list if (list%is_empty ()) return call quick_sort (list%array(:list%count)) contains pure recursive subroutine quick_sort (array) integer, dimension(:), intent(inout) :: array integer :: pivot, tmp integer :: first, last integer i, j first = 1 last = size(array) pivot = array(int ((first+last) / 2.)) i = first j = last do do while (array(i) < pivot) i = i + 1 end do do while (pivot < array(j)) j = j - 1 end do if (i >= j) exit tmp = array(i) array(i) = array(j) array(j) = tmp i = i + 1 j = j - 1 end do if (first < i - 1) call quick_sort(array(first:i - 1)) if (j + 1 < last) call quick_sort(array(j + 1:last)) end subroutine quick_sort end subroutine array_list_sort @ %def array_list_sort @ <>= procedure :: is_element => array_list_is_element <>= pure module function array_list_is_element (list, data) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: data logical :: flag end function array_list_is_element <>= pure module function array_list_is_element (list, data) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: data logical :: flag if (list%is_empty ()) then flag = .false. else flag = any (data == list%array) end if end function array_list_is_element @ %def array_list_is_element @ <>= procedure :: find => array_list_find <>= module function array_list_find (list, data) result (index) class(array_list_t), intent(inout) :: list integer, intent(in) :: data integer :: index end function array_list_find <>= module function array_list_find (list, data) result (index) class(array_list_t), intent(inout) :: list integer, intent(in) :: data integer :: index if (list%is_empty () & .or. .not. list%is_element (data)) then index = 0 return end if call list%sort () !! INTENT(INOUT) index = binary_search_leftmost (list%array(:list%count), data) contains pure function binary_search_leftmost (array, data) result (index) integer, dimension(:), intent(in) :: array integer, intent(in) :: data integer :: index integer :: left, right left = 1 right = size (array) do while (left < right) index = floor ((left + right) / 2.) if (array(index) < data) then left = index + 1 else right = index end if end do index = left end function binary_search_leftmost end function array_list_find @ %def array_list_find @ <>= procedure :: add_at => array_list_add_at <>= module subroutine array_list_add_at (list, index, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer, intent(in) :: data end subroutine array_list_add_at <>= module subroutine array_list_add_at (list, index, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer, intent(in) :: data if (.not. list%is_index (index)) return if (list%is_full ()) then call list%grow_size () end if list%array(index + 1:list%count + 1) = list%array(index:list%count) list%array(index) = data list%count = list%count + 1 end subroutine array_list_add_at @ %def array_list_add_at @ <>= procedure :: remove => array_list_remove <>= module function array_list_remove (list) result (data) class(array_list_t), intent(inout) :: list integer :: data end function array_list_remove <>= module function array_list_remove (list) result (data) class(array_list_t), intent(inout) :: list integer :: data if (list%is_empty ()) then data = 0 return end if data = list%get (list%count) list%array(list%count) = 0 list%count = list%count -1 end function array_list_remove @ %def array_list_remove @ <>= procedure :: remove_at => array_list_remove_at <>= module function array_list_remove_at (list, index) result (data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer :: data end function array_list_remove_at <>= module function array_list_remove_at (list, index) result (data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer :: data if (list%is_empty ()) then data = 0 return end if data = list%get (index) list%array(index:list%count - 1) = list%array(index + 1:list%count) list%array(list%count) = 0 list%count = list%count - 1 end function array_list_remove_at @ %def array_list_remove_at @ \subsection{Unit tests} \label{sec:unit-tests} <<[[array_list_ut.f90]]>>= <> module array_list_ut use unit_tests use array_list_uti <> <> contains <> end module array_list_ut @ %def array_list_ut @ <<[[array_list_uti.f90]]>>= <> module array_list_uti use array_list <> <> contains <> end module array_list_uti @ %def array_list_uti @ <>= public :: array_list_test <>= subroutine array_list_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine array_list_test @ %def array_list_test @ Provide testing for interface stability and correct implementation for the binary tree and its iterator. <>= call test (array_list_1, "array_list_1", & "check interface and implementation", & u, results) <>= public :: array_list_1 <>= subroutine array_list_1 (u) integer, intent(in) :: u type(array_list_t) :: list integer :: ndx, data write (u, "(A)") "* Test output: Array list" write (u, "(A)") "* Purpose: test interface and implementation of array list" write (u, "(A)") write (u, "(A)") "* Init array_list_t ..." call list%init () write (u, "(A)") "* Test adding a single element..." call list%add (1) write (u, "(A)") "* Test removing a single element..." data = list%remove () write (u, "(A)") "* Test growing (unnecessary, so just return)..." call list%grow_size () write (u, "(A)") "* Test adding elements beyond initial capacity..." call test_grow_and_add (list) write (u, "(A)") "* Test adding at specific position..." call list%add_at (10, -1) write (u, "(A)") "* Test removing at specific position..." data = list%remove_at (11) write (u, "(A)") "* Test reverse ordering..." call list%reverse_order () write (u, "(A)") "* Test sorting..." call list%sort () write (u, "(A)") "* Test finding..." ndx = list%find (1) write (u, "(A)") "* Test shrinking..." call list%shrink_size () write (u, "(A)") "* Test get procedures..." call test_get_procedures (list) write (u, "(A)") "* Test clearing list..." call list%clear () write (u, "(A)") "* Test (more complicated) combinations:" write (u, "(A)") "* Test growing (necessary) during adding..." call test_grow_and_add (list) write (u, "(A)") "* Test adding random data and sorting..." call test_sort (list) write (u, "(A)") "* Test finding (before sorted)..." call test_find (list) contains subroutine test_get_procedures (list) type(array_list_t), intent(in) :: list integer :: n logical :: flag n = list%get(1) n = list%get_size () n = list%get_count () flag = list%is_element (1) end subroutine test_get_procedures subroutine test_grow_and_add (list) type(array_list_t), intent(inout) :: list integer :: i do i = 1, 2 * list%get_size () call list%add (i) end do end subroutine test_grow_and_add subroutine test_get (list) class(array_list_t), intent(inout) :: list integer :: i, data do i = list%get_count (), 1, -1 data = list%get (i) if (data == 0) then write (u, "(A,1X,I3)") "INDEX EMPTY", i end if end do end subroutine test_get subroutine test_sort (list) class(array_list_t), intent(inout) :: list call list%add (6) call list%add (2) call list%add (9) call list%add (4) call list%add (8) call list%add (7) call list%sort () end subroutine test_sort subroutine test_find (list) class(array_list_t), intent(inout) :: list write (u, "(A,1X,I3)") " 6 INDEX", list%find (6) write (u, "(A,1X,I3)") "-1 INDEX", list%find (-1) write (u, "(A,1X,I3)") " 3 INDEX", list%find (3) write (u, "(A,1X,I3)") "26 INDEX", list%find (26) call list%write (u) end subroutine test_find end subroutine array_list_1 @ %def array_list_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Queue} <<[[queue.f90]]>>= <> module queue <> <> <> <> interface <> end interface end module queue @ %def queue @ <<[[queue_sub.f90]]>>= <> submodule (queue) queue_s use, intrinsic :: iso_fortran_env, only: ERROR_UNIT implicit none contains <> end submodule queue_s @ %def queue_s @ <>= integer, parameter :: QUEUE_SIZE = 10, & QUEUE_START = 0, & QUEUE_END = QUEUE_SIZE @ %def queue_size queue_start queue_end @ <>= public :: queue_t <>= type :: queue_t private integer, dimension(QUEUE_SIZE) :: item integer :: front = 0 integer :: rear = 0 contains <> end type queue_t @ %def queue_t @ <>= procedure :: is_full => queue_is_full <>= elemental module function queue_is_full (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag end function queue_is_full <>= elemental module function queue_is_full (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag flag = queue%front == 1 .and. queue%rear == QUEUE_END end function queue_is_full @ %def queue_is_full @ <>= procedure :: is_empty => queue_is_empty <>= elemental module function queue_is_empty (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag end function queue_is_empty <>= elemental module function queue_is_empty (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag flag = queue%front == QUEUE_START end function queue_is_empty @ %def queue_is_empty @ <>= procedure :: enqueue => queue_enqueue <>= module subroutine queue_enqueue (queue, item) class(queue_t), intent(inout) :: queue integer, intent(in) :: item end subroutine queue_enqueue <>= module subroutine queue_enqueue (queue, item) class(queue_t), intent(inout) :: queue integer, intent(in) :: item if (queue%is_full ()) then !! Do something. else if (queue%front == QUEUE_START) queue%front = 1 queue%rear = queue%rear + 1 queue%item(queue%rear) = item end if end subroutine queue_enqueue @ %def queue_enqueue @ <>= procedure :: dequeue => queue_dequeue <>= module function queue_dequeue (queue) result (item) class(queue_t), intent(inout) :: queue integer :: item end function queue_dequeue <>= module function queue_dequeue (queue) result (item) class(queue_t), intent(inout) :: queue integer :: item if (queue%is_empty ()) then item = 0 else item = queue%item(queue%front) if (queue%front >= queue%rear) then queue%front = QUEUE_START queue%rear = QUEUE_START !! Q has only one element, !! so we reset the queue after deleting it. else queue%front = queue%front + 1 end if end if end function queue_dequeue @ %def queue_dequeue @ <>= procedure :: peek => queue_peek <>= module function queue_peek (queue) result (item) class(queue_t), intent(in) :: queue integer :: item end function queue_peek <>= module function queue_peek (queue) result (item) class(queue_t), intent(in) :: queue integer :: item if (queue%is_empty ()) then item = 0 else item = queue%item(queue%front) end if end function queue_peek @ %def queue_peek @ <>= procedure :: write => queue_write <>= module subroutine queue_write (queue, unit) class(queue_t), intent(in) :: queue integer, intent(in), optional :: unit end subroutine queue_write <>= module subroutine queue_write (queue, unit) class(queue_t), intent(in) :: queue integer, intent(in), optional :: unit integer :: u, i u = ERROR_UNIT; if (present (unit)) u = unit if (queue%is_empty ()) then write (u, *) "Empty Queue." else write (u, *) "Front ->", queue%front write (u, *) "Items ->" do i = 1, queue%rear write (u, *) queue%item(i) end do write (u, *) "Rear ->", queue%rear end if end subroutine queue_write @ %def queue_write @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Iterator} <<[[iterator.f90]]>>= <> module iterator <> <> <> interface <> end interface end module iterator @ %def iterator @ <<[[iterator_sub.f90]]>>= <> submodule (iterator) iterator_s use, intrinsic :: iso_fortran_env, only: ERROR_UNIT implicit none contains <> end submodule iterator_s @ %def iterator_s @ <>= public :: iterator_t <>= !! Forward type :: iterator_t integer :: current = 0 integer :: begin = 0 integer :: end = 0 integer :: step = 1 contains <> end type iterator_t @ %def iterator_t @ <>= procedure :: write => iterator_write <>= module subroutine iterator_write (iter, unit) class(iterator_t), intent(in) :: iter integer, intent(in), optional :: unit end subroutine iterator_write <>= module subroutine iterator_write (iter, unit) class(iterator_t), intent(in) :: iter integer, intent(in), optional :: unit integer :: u u = ERROR_UNIT; if (present (unit)) u = unit write (u, "(3(A,1X,I3,1X))") "CURRENT", iter%current, & "BEGIN", iter%begin, "END", iter%end flush (u) end subroutine iterator_write @ %def iterator_write @ <>= procedure :: init => iterator_init <>= module subroutine iterator_init (iter, begin, end, step) class(iterator_t), intent(inout) :: iter integer, intent(in) :: begin integer, intent(in) :: end integer, intent(in), optional :: step end subroutine iterator_init <>= !! Proof: step > 0, begin < end. !! Proof: step < 0, begin > end. !! Proof: step /= 0. module subroutine iterator_init (iter, begin, end, step) class(iterator_t), intent(inout) :: iter integer, intent(in) :: begin integer, intent(in) :: end integer, intent(in), optional :: step iter%begin = begin iter%end = end iter%step = 1; if (present (step)) iter%step = step if (abs (iter%step) > 0) then iter%current = iter%begin else write (ERROR_UNIT, "(A)") "ERROR: Step size MUST be unequal to zero." stop 1 end if end subroutine iterator_init @ %def iterator_init @ <>= procedure :: at_begin => iterator_at_begin <>= pure module function iterator_at_begin (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag end function iterator_at_begin <>= pure module function iterator_at_begin (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag flag = iter%current == iter%begin end function iterator_at_begin @ %def iterator_at_begin @ <>= procedure :: at_end => iterator_at_end <>= pure module function iterator_at_end (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag end function iterator_at_end <>= pure module function iterator_at_end (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag flag = iter%current == iter%end end function iterator_at_end @ %def iterator_at_end @ <>= procedure :: is_iterable => iterator_is_iterable <>= pure module function iterator_is_iterable (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag end function iterator_is_iterable <>= !! Proof: begin < current < end pure module function iterator_is_iterable (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag if (iter%step > 0) then flag = iter%current <= iter%end else if (iter%step < 0) then flag = iter%current >= iter%end else flag = .false. end if end function iterator_is_iterable @ %def iterator_is_iterable @ <>= procedure :: next_step => iterator_next_step <>= module subroutine iterator_next_step (iter) class(iterator_t), intent(inout) :: iter end subroutine iterator_next_step <>= module subroutine iterator_next_step (iter) class(iterator_t), intent(inout) :: iter if (.not. iter%is_iterable ()) return iter%current = iter%current + iter%step end subroutine iterator_next_step @ %def iterator_next_step @ <>= procedure :: next => iterator_next <>= module function iterator_next (iter) result (ndx) class(iterator_t), intent(inout) :: iter integer :: ndx end function iterator_next <>= !! Proof: begin <= current <= end. !! However, after applying the step, this does not need to be true.. module function iterator_next (iter) result (ndx) class(iterator_t), intent(inout) :: iter integer :: ndx if (.not. iter%is_iterable ()) then ndx = 0 return end if ndx = iter%current iter%current = iter%current + iter%step end function iterator_next @ %def iterator_next @ <>= procedure :: get_current => iterator_get_current <>= pure module function iterator_get_current (iter) result (ndx) class(iterator_t), intent(in) :: iter integer :: ndx end function iterator_get_current <>= pure module function iterator_get_current (iter) result (ndx) class(iterator_t), intent(in) :: iter integer :: ndx if (.not. iter%is_iterable ()) then ndx = 0 return end if ndx = iter%current end function iterator_get_current @ %def iterator_get_current @ \subsection{Unit tests} \label{sec:unit-tests} <<[[iterator_ut.f90]]>>= <> module iterator_ut use unit_tests use iterator_uti <> <> contains <> end module iterator_ut @ %def iterator_ut @ <<[[iterator_uti.f90]]>>= <> module iterator_uti use iterator <> <> contains <> end module iterator_uti @ %def iterator_uti @ <>= public :: iterator_test <>= subroutine iterator_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine iterator_test @ %def iterator_test @ Provide testing for interface stability and correct implementation for the forward integer iterator. <>= call test (iterator_1, "iterator_1", & "check interface and implementation", & u, results) <>= public :: iterator_1 <>= subroutine iterator_1 (u) integer, intent(in) :: u type(iterator_t) :: iter write (u, "(A)") "* Test output: iterator_1" write (u, "(A)") "* Purpose: test interface and implementation of the forward integer iterator" write (u, "(A)") call iter%init (1, 10) call iter%write (u) do while (iter%is_iterable ()) write (u, "(A,1X,I3)") "NDX", iter%next () end do call iter%init (10, 1, -1) call iter%write (u) do while (iter%is_iterable ()) write (u, "(A,1X,I3)") "NDX", iter%next () end do write (u, "(A,1X,I3)") "INVALID NDX", iter%next () call iter%init (1, 10) call iter%write (u) do while (iter%is_iterable ()) call iter%next_step () write (u, "(A)") "STEP." end do end subroutine iterator_1 @ Index: trunk/src/physics/physics.nw =================================================================== --- trunk/src/physics/physics.nw (revision 8775) +++ trunk/src/physics/physics.nw (revision 8776) @@ -1,6882 +1,8379 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: physics and such \chapter{Physics} \includemodulegraph{physics} Here we collect definitions and functions that we need for (particle) physics in general, to make them available for the more specific needs of WHIZARD. \begin{description} \item[physics\_defs] Physical constants. \item[c\_particles] A simple data type for particles which is C compatible. \item[lorentz] Define three-vectors, four-vectors and Lorentz transformations and common operations for them. \item[phs\_point] Collections of Lorentz vectors. \item[sm\_physics] Here, running functions are stored for special kinematical setup like running coupling constants, Catani-Seymour dipoles, or Sudakov factors. \item[sm\_qcd] Definitions and methods for dealing with the running QCD coupling. \item[shower\_algorithms] Algorithms typically used in Parton Showers as well as in their matching to NLO computations, e.g. with the POWHEG method. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Physics Constants} There is also the generic [[constants]] module. The constants listed here are more specific for particle physics. <<[[physics_defs.f90]]>>= <> module physics_defs <> <> use constants, only: one, two, three <> <> <> <> + interface +<> + end interface + +end module physics_defs +@ %def physics_defs +@ +<<[[physics_defs_sub.f90]]>>= +<> + +submodule (physics_defs) physics_defs_s + + implicit none + contains <> -end module physics_defs -@ %def physics_defs +end submodule physics_defs_s + +@ %def physics_defs_s @ \subsection{Units} Conversion from energy units to cross-section units. <>= real(default), parameter, public :: & conv = 0.38937966e12_default @ Conversion from millimeter to nanoseconds for lifetimes. <>= real(default), parameter, public :: & ns_per_mm = 1.e6_default / 299792458._default @ Rescaling factor. <>= real(default), parameter, public :: & pb_per_fb = 1.e-3_default @ String for the default energy and cross-section units. <>= character(*), parameter, public :: & energy_unit = "GeV" character(*), parameter, public :: & cross_section_unit = "fb" @ \subsection{SM and QCD constants} <>= real(default), parameter, public :: & NC = three, & CF = (NC**2 - one) / two / NC, & CA = NC, & TR = one / two @ \subsection{Parameter Reference values} These are used exclusively in the context of running QCD parameters. In other contexts, we rely on the uniform parameter set as provided by the model definition, modifiable by the user. <>= real(default), public, parameter :: MZ_REF = 91.188_default real(default), public, parameter :: ME_REF = 0.000510998928_default real(default), public, parameter :: ALPHA_QCD_MZ_REF = 0.1178_default real(default), public, parameter :: ALPHA_QED_ME_REF = 0.0072973525693_default real(default), public, parameter :: LAMBDA_QCD_REF = 200.e-3_default @ %def alpha_s_mz_ref mz_ref lambda_qcd_ref @ \subsection{Particle codes} Let us define a few particle codes independent of the model. We need an UNDEFINED value: <>= integer, parameter, public :: UNDEFINED = 0 @ %def UNDEFINED @ SM fermions: <>= integer, parameter, public :: DOWN_Q = 1 integer, parameter, public :: UP_Q = 2 integer, parameter, public :: STRANGE_Q = 3 integer, parameter, public :: CHARM_Q = 4 integer, parameter, public :: BOTTOM_Q = 5 integer, parameter, public :: TOP_Q = 6 integer, parameter, public :: ELECTRON = 11 integer, parameter, public :: ELECTRON_NEUTRINO = 12 integer, parameter, public :: MUON = 13 integer, parameter, public :: MUON_NEUTRINO = 14 integer, parameter, public :: TAU = 15 integer, parameter, public :: TAU_NEUTRINO = 16 @ %def ELECTRON MUON TAU @ Gauge bosons: <>= integer, parameter, public :: GLUON = 21 integer, parameter, public :: PHOTON = 22 integer, parameter, public :: PHOTON_OFFSHELL = -2002 integer, parameter, public :: PHOTON_ONSHELL = 2002 integer, parameter, public :: Z_BOSON = 23 integer, parameter, public :: W_BOSON = 24 @ %def GLUON PHOTON Z_BOSON W_BOSON @ Light mesons: <>= integer, parameter, public :: PION = 111 integer, parameter, public :: PIPLUS = 211 integer, parameter, public :: PIMINUS = - PIPLUS @ %def PION PIPLUS PIMINUS @ Di-Quarks: <>= integer, parameter, public :: UD0 = 2101 integer, parameter, public :: UD1 = 2103 integer, parameter, public :: UU1 = 2203 @ %def UD0 UD1 UU1 @ Mesons: <>= integer, parameter, public :: K0L = 130 integer, parameter, public :: K0S = 310 integer, parameter, public :: K0 = 311 integer, parameter, public :: KPLUS = 321 integer, parameter, public :: DPLUS = 411 integer, parameter, public :: D0 = 421 integer, parameter, public :: B0 = 511 integer, parameter, public :: BPLUS = 521 @ %def K0L K0S K0 KPLUS DPLUS D0 B0 BPLUS @ Light baryons: <>= integer, parameter, public :: PROTON = 2212 integer, parameter, public :: NEUTRON = 2112 integer, parameter, public :: DELTAPLUSPLUS = 2224 integer, parameter, public :: DELTAPLUS = 2214 integer, parameter, public :: DELTA0 = 2114 integer, parameter, public :: DELTAMINUS = 1114 @ %def PROTON NEUTRON DELTAPLUSPLUS DELTAPLUS DELTA0 DELTAMINUS @ Strange baryons: <>= integer, parameter, public :: SIGMAPLUS = 3222 integer, parameter, public :: SIGMA0 = 3212 integer, parameter, public :: SIGMAMINUS = 3112 @ %def SIGMAPLUS SIGMA0 SIGMAMINUS @ Charmed baryons: <>= integer, parameter, public :: SIGMACPLUSPLUS = 4222 integer, parameter, public :: SIGMACPLUS = 4212 integer, parameter, public :: SIGMAC0 = 4112 @ %def SIGMACPLUSPLUS SIGMACPLUS SIGMAC0 @ Bottom baryons: <>= integer, parameter, public :: SIGMAB0 = 5212 integer, parameter, public :: SIGMABPLUS = 5222 @ %def SIGMAB0 SIGMABPLUS @ 81-100 are reserved for internal codes. Hadron and beam remnants: <>= integer, parameter, public :: BEAM_REMNANT = 9999 integer, parameter, public :: HADRON_REMNANT = 90 integer, parameter, public :: HADRON_REMNANT_SINGLET = 91 integer, parameter, public :: HADRON_REMNANT_TRIPLET = 92 integer, parameter, public :: HADRON_REMNANT_OCTET = 93 @ %def BEAM_REMNANT HADRON_REMNANT @ %def HADRON_REMNANT_SINGLET HADRON_REMNANT_TRIPLET HADRON_REMNANT_OCTET @ Further particle codes for internal use: <>= integer, parameter, public :: INTERNAL = 94 integer, parameter, public :: INVALID = 97 integer, parameter, public :: COMPOSITE = 99 @ %def INTERNAL INVALID COMPOSITE @ \subsection{Spin codes} Somewhat redundant, but for better readability we define named constants for spin types. If the mass is nonzero, this is equal to the number of degrees of freedom. <>= integer, parameter, public:: UNKNOWN = 0 integer, parameter, public :: SCALAR = 1, SPINOR = 2, VECTOR = 3, & VECTORSPINOR = 4, TENSOR = 5 @ %def UNKNOWN SCALAR SPINOR VECTOR VECTORSPINOR TENSOR @ Isospin types and charge types are counted in an analogous way, where charge type 1 is charge 0, 2 is charge 1/3, and so on. Zero always means unknown. Note that charge and isospin types have an explicit sign. Color types are defined as the dimension of the representation. \subsection{NLO status codes} Used to specify whether a [[term_instance_t]] of a [[process_instance_t]] is associated with a Born, real-subtracted, virtual-subtracted or subtraction-dummy matrix element. <>= integer, parameter, public :: BORN = 0 integer, parameter, public :: NLO_REAL = 1 integer, parameter, public :: NLO_VIRTUAL = 2 integer, parameter, public :: NLO_MISMATCH = 3 integer, parameter, public :: NLO_DGLAP = 4 integer, parameter, public :: NLO_SUBTRACTION = 5 integer, parameter, public :: NLO_FULL = 6 integer, parameter, public :: GKS = 7 integer, parameter, public :: COMPONENT_UNDEFINED = 99 @ % def BORN, NLO_REAL, NLO_VIRTUAL, NLO_SUBTRACTION, GKS @ [[NLO_FULL]] is not strictly a component status code but having it is convenient. We define the number of additional subtractions for beam-involved NLO calculations. Each subtraction refers to a rescaling of one of two beams. Obviously, this approach is not flexible enough to support setups with just a single beam described by a structure function. <>= integer, parameter, public :: n_beams_rescaled = 2 @ %def n_beams_rescaled @ <>= public :: component_status <>= interface component_status module procedure component_status_of_string module procedure component_status_to_string end interface +<>= + elemental module function component_status_of_string (string) result (i) + integer :: i + type(string_t), intent(in) :: string + end function component_status_of_string + elemental module function component_status_to_string (i) result (string) + type(string_t) :: string + integer, intent(in) :: i + end function component_status_to_string <>= - elemental function component_status_of_string (string) result (i) + elemental module function component_status_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string select case (char(string)) case ("born") i = BORN case ("real") i = NLO_REAL case ("virtual") i = NLO_VIRTUAL case ("mismatch") i = NLO_MISMATCH case ("dglap") i = NLO_DGLAP case ("subtraction") i = NLO_SUBTRACTION case ("full") i = NLO_FULL case ("GKS") i = GKS case default i = COMPONENT_UNDEFINED end select end function component_status_of_string - elemental function component_status_to_string (i) result (string) + elemental module function component_status_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i select case (i) case (BORN) string = "born" case (NLO_REAL) string = "real" case (NLO_VIRTUAL) string = "virtual" case (NLO_MISMATCH) string = "mismatch" case (NLO_DGLAP) string = "dglap" case (NLO_SUBTRACTION) string = "subtraction" case (NLO_FULL) string = "full" case (GKS) string = "GKS" case default string = "undefined" end select end function component_status_to_string @ %def component_status @ <>= public :: is_nlo_component +<>= + elemental module function is_nlo_component (comp) result (is_nlo) + logical :: is_nlo + integer, intent(in) :: comp + end function is_nlo_component <>= - elemental function is_nlo_component (comp) result (is_nlo) + elemental module function is_nlo_component (comp) result (is_nlo) logical :: is_nlo integer, intent(in) :: comp select case (comp) case (BORN : GKS) is_nlo = .true. case default is_nlo = .false. end select end function is_nlo_component @ %def is_nlo_component @ <>= public :: is_subtraction_component +<>= + module function is_subtraction_component (emitter, nlo_type) result (is_subtraction) + logical :: is_subtraction + integer, intent(in) :: emitter, nlo_type + end function is_subtraction_component <>= - function is_subtraction_component (emitter, nlo_type) result (is_subtraction) + module function is_subtraction_component (emitter, nlo_type) result (is_subtraction) logical :: is_subtraction integer, intent(in) :: emitter, nlo_type is_subtraction = nlo_type == NLO_REAL .and. emitter < 0 end function is_subtraction_component @ %def is_subtraction_component @ \subsection{Threshold} Some commonly used variables for the threshold computation <>= integer, parameter, public :: THR_POS_WP = 3 integer, parameter, public :: THR_POS_WM = 4 integer, parameter, public :: THR_POS_B = 5 integer, parameter, public :: THR_POS_BBAR = 6 integer, parameter, public :: THR_POS_GLUON = 7 integer, parameter, public :: THR_EMITTER_OFFSET = 4 integer, parameter, public :: NO_FACTORIZATION = 0 integer, parameter, public :: FACTORIZATION_THRESHOLD = 1 integer, dimension(2), parameter, public :: ass_quark = [5, 6] integer, dimension(2), parameter, public :: ass_boson = [3, 4] integer, parameter, public :: PROC_MODE_UNDEFINED = 0 integer, parameter, public :: PROC_MODE_TT = 1 integer, parameter, public :: PROC_MODE_WBWB = 2 @ @ <>= public :: thr_leg +<>= + module function thr_leg (emitter) result (leg) + integer :: leg + integer, intent(in) :: emitter + end function thr_leg <>= - function thr_leg (emitter) result (leg) + module function thr_leg (emitter) result (leg) integer :: leg integer, intent(in) :: emitter leg = emitter - THR_EMITTER_OFFSET end function thr_leg @ %def thr_leg @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{C-compatible Particle Type} For easy communication with C code, we introduce a simple C-compatible type for particles. The components are either default C integers or default C doubles. The [[c_prt]] type is transparent, and its contents should be regarded as part of the interface. <<[[c_particles.f90]]>>= <> module c_particles use, intrinsic :: iso_c_binding !NODEP! - use io_units - use format_defs, only: FMT_14, FMT_19 - <> <> <> -contains + interface +<> + end interface -<> end module c_particles @ %def c_particles @ +<<[[c_particles_sub.f90]]>>= +<> + +submodule (c_particles) c_particles_s + + use io_units + use format_defs, only: FMT_14, FMT_19 + + implicit none + +contains + +<> + +end submodule c_particles_s + +@ %def c_particles_s +@ <>= public :: c_prt_t <>= type, bind(C) :: c_prt_t integer(c_int) :: type = 0 integer(c_int) :: pdg = 0 integer(c_int) :: polarized = 0 integer(c_int) :: h = 0 real(c_double) :: pe = 0 real(c_double) :: px = 0 real(c_double) :: py = 0 real(c_double) :: pz = 0 real(c_double) :: p2 = 0 end type c_prt_t @ %def c_prt_t @ This is for debugging only, there is no C binding. It is a simplified version of [[prt_write]]. <>= public :: c_prt_write +<>= + module subroutine c_prt_write (prt, unit) + type(c_prt_t), intent(in) :: prt + integer, intent(in), optional :: unit + end subroutine c_prt_write <>= - subroutine c_prt_write (prt, unit) + module subroutine c_prt_write (prt, unit) type(c_prt_t), intent(in) :: prt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)", advance="no") "prt(" write (u, "(I0,':')", advance="no") prt%type if (prt%polarized /= 0) then write (u, "(I0,'/',I0,'|')", advance="no") prt%pdg, prt%h else write (u, "(I0,'|')", advance="no") prt%pdg end if write (u, "(" // FMT_14 // ",';'," // FMT_14 // ",','," // & FMT_14 // ",','," // FMT_14 // ")", advance="no") & prt%pe, prt%px, prt%py, prt%pz write (u, "('|'," // FMT_19 // ")", advance="no") prt%p2 write (u, "(A)") ")" end subroutine c_prt_write @ %def c_prt_write @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Lorentz algebra} Define Lorentz vectors, three-vectors, boosts, and some functions to manipulate them. To make maximum use of this, all functions, if possible, are declared elemental (or pure, if this is not possible). <<[[lorentz.f90]]>>= <> module lorentz <> - use numeric_utils - use io_units - use constants, only: pi, twopi, degree, zero, one, two, eps0, tiny_07 - use format_defs, only: FMT_11, FMT_13, FMT_15, FMT_19 - use format_utils, only: pac_fmt - use diagnostics + use constants, only: zero, one use c_particles <> <> <> <> <> <> <> -contains + interface +<> + end interface -<> end module lorentz @ %def lorentz @ +<<[[lorentz_sub.f90]]>>= +<> + +submodule (lorentz) lorentz_s + + use constants, only: pi, twopi, degree, two, tiny_07, eps0 + use numeric_utils + use io_units + use format_defs, only: FMT_11, FMT_13, FMT_15, FMT_19 + use format_utils, only: pac_fmt + use diagnostics + + implicit none + +contains + +<> + +end submodule lorentz_s + +@ %def lorentz_s +@ \subsection{Three-vectors} First of all, let us introduce three-vectors in a trivial way. The functions and overloaded elementary operations clearly are too much overhead, but we like to keep the interface for three-vectors and four-vectors exactly parallel. By the way, we might attach a label to a vector by extending the type definition later. <>= public :: vector3_t <>= type :: vector3_t real(default), dimension(3) :: p end type vector3_t @ %def vector3_t @ Output a vector <>= public :: vector3_write +<>= + module subroutine vector3_write (p, unit, testflag) + type(vector3_t), intent(in) :: p + integer, intent(in), optional :: unit + logical, intent(in), optional :: testflag + end subroutine vector3_write <>= - subroutine vector3_write (p, unit, testflag) + module subroutine vector3_write (p, unit, testflag) type(vector3_t), intent(in) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: testflag character(len=7) :: fmt integer :: u u = given_output_unit (unit); if (u < 0) return call pac_fmt (fmt, FMT_19, FMT_15, testflag) write(u, "(1x,A,3(1x," // fmt // "))") 'P = ', p%p end subroutine vector3_write @ %def vector3_write @ This is a three-vector with zero components <>= public :: vector3_null <>= type(vector3_t), parameter :: vector3_null = & vector3_t ([ zero, zero, zero ]) @ %def vector3_null @ Canonical three-vector: <>= public :: vector3_canonical +<>= + elemental module function vector3_canonical (k) result (p) + type(vector3_t) :: p + integer, intent(in) :: k + end function vector3_canonical <>= - elemental function vector3_canonical (k) result (p) + elemental module function vector3_canonical (k) result (p) type(vector3_t) :: p integer, intent(in) :: k p = vector3_null p%p(k) = 1 end function vector3_canonical @ %def vector3_canonical @ A moving particle ($k$-axis, or arbitrary axis). Note that the function for the generic momentum cannot be elemental. <>= public :: vector3_moving <>= interface vector3_moving module procedure vector3_moving_canonical module procedure vector3_moving_generic end interface +<>= + elemental module function vector3_moving_canonical (p, k) result(q) + type(vector3_t) :: q + real(default), intent(in) :: p + integer, intent(in) :: k + end function vector3_moving_canonical + pure module function vector3_moving_generic (p) result(q) + real(default), dimension(3), intent(in) :: p + type(vector3_t) :: q + end function vector3_moving_generic <>= - elemental function vector3_moving_canonical (p, k) result(q) + elemental module function vector3_moving_canonical (p, k) result(q) type(vector3_t) :: q real(default), intent(in) :: p integer, intent(in) :: k q = vector3_null q%p(k) = p end function vector3_moving_canonical - pure function vector3_moving_generic (p) result(q) + pure module function vector3_moving_generic (p) result(q) real(default), dimension(3), intent(in) :: p type(vector3_t) :: q q%p = p end function vector3_moving_generic @ %def vector3_moving @ Equality and inequality <>= public :: operator(==), operator(/=) <>= interface operator(==) module procedure vector3_eq end interface interface operator(/=) module procedure vector3_neq end interface +<>= + elemental module function vector3_eq (p, q) result (r) + logical :: r + type(vector3_t), intent(in) :: p,q + end function vector3_eq + elemental module function vector3_neq (p, q) result (r) + logical :: r + type(vector3_t), intent(in) :: p,q + end function vector3_neq <>= - elemental function vector3_eq (p, q) result (r) + elemental module function vector3_eq (p, q) result (r) logical :: r type(vector3_t), intent(in) :: p,q r = all (abs (p%p - q%p) < eps0) end function vector3_eq - elemental function vector3_neq (p, q) result (r) + elemental module function vector3_neq (p, q) result (r) logical :: r type(vector3_t), intent(in) :: p,q r = any (abs(p%p - q%p) > eps0) end function vector3_neq @ %def == /= @ Define addition and subtraction <>= public :: operator(+), operator(-) <>= interface operator(+) module procedure add_vector3 end interface interface operator(-) module procedure sub_vector3 end interface +<>= + elemental module function add_vector3 (p, q) result (r) + type(vector3_t) :: r + type(vector3_t), intent(in) :: p,q + end function add_vector3 + elemental module function sub_vector3 (p, q) result (r) + type(vector3_t) :: r + type(vector3_t), intent(in) :: p,q + end function sub_vector3 <>= - elemental function add_vector3 (p, q) result (r) + elemental module function add_vector3 (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q r%p = p%p + q%p end function add_vector3 - elemental function sub_vector3 (p, q) result (r) + elemental module function sub_vector3 (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q r%p = p%p - q%p end function sub_vector3 @ %def + - @ The multiplication sign is overloaded with scalar multiplication; similarly division: <>= public :: operator(*), operator(/) <>= interface operator(*) module procedure prod_integer_vector3, prod_vector3_integer module procedure prod_real_vector3, prod_vector3_real end interface interface operator(/) module procedure div_vector3_real, div_vector3_integer end interface +<>= + elemental module function prod_real_vector3 (s, p) result (q) + type(vector3_t) :: q + real(default), intent(in) :: s + type(vector3_t), intent(in) :: p + end function prod_real_vector3 + elemental module function prod_vector3_real (p, s) result (q) + type(vector3_t) :: q + real(default), intent(in) :: s + type(vector3_t), intent(in) :: p + end function prod_vector3_real + elemental module function div_vector3_real (p, s) result (q) + type(vector3_t) :: q + real(default), intent(in) :: s + type(vector3_t), intent(in) :: p + end function div_vector3_real + elemental module function prod_integer_vector3 (s, p) result (q) + type(vector3_t) :: q + integer, intent(in) :: s + type(vector3_t), intent(in) :: p + end function prod_integer_vector3 + elemental module function prod_vector3_integer (p, s) result (q) + type(vector3_t) :: q + integer, intent(in) :: s + type(vector3_t), intent(in) :: p + end function prod_vector3_integer + elemental module function div_vector3_integer (p, s) result (q) + type(vector3_t) :: q + integer, intent(in) :: s + type(vector3_t), intent(in) :: p + end function div_vector3_integer <>= - elemental function prod_real_vector3 (s, p) result (q) + elemental module function prod_real_vector3 (s, p) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_real_vector3 - elemental function prod_vector3_real (p, s) result (q) + elemental module function prod_vector3_real (p, s) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_vector3_real - elemental function div_vector3_real (p, s) result (q) + elemental module function div_vector3_real (p, s) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p q%p = p%p/s end function div_vector3_real - elemental function prod_integer_vector3 (s, p) result (q) + elemental module function prod_integer_vector3 (s, p) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_integer_vector3 - elemental function prod_vector3_integer (p, s) result (q) + elemental module function prod_vector3_integer (p, s) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_vector3_integer - elemental function div_vector3_integer (p, s) result (q) + elemental module function div_vector3_integer (p, s) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p q%p = p%p/s end function div_vector3_integer @ %def * / @ The multiplication sign can also indicate scalar products: <>= interface operator(*) module procedure prod_vector3 end interface +<>= + elemental module function prod_vector3 (p, q) result (s) + real(default) :: s + type(vector3_t), intent(in) :: p,q + end function prod_vector3 <>= - elemental function prod_vector3 (p, q) result (s) + elemental module function prod_vector3 (p, q) result (s) real(default) :: s type(vector3_t), intent(in) :: p,q s = dot_product (p%p, q%p) end function prod_vector3 @ %def * <>= public :: cross_product <>= interface cross_product module procedure vector3_cross_product end interface +<>= + elemental module function vector3_cross_product (p, q) result (r) + type(vector3_t) :: r + type(vector3_t), intent(in) :: p,q + end function vector3_cross_product <>= - elemental function vector3_cross_product (p, q) result (r) + elemental module function vector3_cross_product (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q integer :: i do i=1,3 r%p(i) = dot_product (p%p, matmul(epsilon_three(i,:,:), q%p)) end do end function vector3_cross_product @ %def cross_product @ Exponentiation is defined only for integer powers. Odd powers mean take the square root; so [[p**1]] is the length of [[p]]. <>= public :: operator(**) <>= interface operator(**) module procedure power_vector3 end interface +<>= + elemental module function power_vector3 (p, e) result (s) + real(default) :: s + type(vector3_t), intent(in) :: p + integer, intent(in) :: e + end function power_vector3 <>= - elemental function power_vector3 (p, e) result (s) + elemental module function power_vector3 (p, e) result (s) real(default) :: s type(vector3_t), intent(in) :: p integer, intent(in) :: e s = dot_product (p%p, p%p) if (e/=2) then if (mod(e,2)==0) then s = s**(e/2) else s = sqrt(s)**e end if end if end function power_vector3 @ %def ** @ Finally, we need a negation. <>= interface operator(-) module procedure negate_vector3 end interface +<>= + elemental module function negate_vector3 (p) result (q) + type(vector3_t) :: q + type(vector3_t), intent(in) :: p + end function negate_vector3 <>= - elemental function negate_vector3 (p) result (q) + elemental module function negate_vector3 (p) result (q) type(vector3_t) :: q type(vector3_t), intent(in) :: p integer :: i do i = 1, 3 if (abs (p%p(i)) < eps0) then q%p(i) = 0 else q%p(i) = -p%p(i) end if end do end function negate_vector3 @ %def - @ The sum function can be useful: <>= public :: sum <>= interface sum module procedure sum_vector3 end interface @ %def sum @ <>= public :: vector3_set_component +<>= + module subroutine vector3_set_component (p, i, value) + type(vector3_t), intent(inout) :: p + integer, intent(in) :: i + real(default), intent(in) :: value + end subroutine vector3_set_component <>= - subroutine vector3_set_component (p, i, value) + module subroutine vector3_set_component (p, i, value) type(vector3_t), intent(inout) :: p integer, intent(in) :: i real(default), intent(in) :: value p%p(i) = value end subroutine vector3_set_component @ %def vector3_set_component @ +<>= + pure module function sum_vector3 (p) result (q) + type(vector3_t) :: q + type(vector3_t), dimension(:), intent(in) :: p + end function sum_vector3 <>= - pure function sum_vector3 (p) result (q) + pure module function sum_vector3 (p) result (q) type(vector3_t) :: q type(vector3_t), dimension(:), intent(in) :: p integer :: i do i=1, 3 q%p(i) = sum (p%p(i)) end do end function sum_vector3 @ %def sum @ Any component: <>= public :: vector3_get_component @ %def component +<>= + elemental module function vector3_get_component (p, k) result (c) + type(vector3_t), intent(in) :: p + integer, intent(in) :: k + real(default) :: c + end function vector3_get_component <>= - elemental function vector3_get_component (p, k) result (c) + elemental module function vector3_get_component (p, k) result (c) type(vector3_t), intent(in) :: p integer, intent(in) :: k real(default) :: c c = p%p(k) end function vector3_get_component @ %def vector3_get_component @ Extract all components. This is not elemental. <>= public :: vector3_get_components +<>= + pure module function vector3_get_components (p) result (a) + type(vector3_t), intent(in) :: p + real(default), dimension(3) :: a + end function vector3_get_components <>= - pure function vector3_get_components (p) result (a) + pure module function vector3_get_components (p) result (a) type(vector3_t), intent(in) :: p real(default), dimension(3) :: a a = p%p end function vector3_get_components @ %def vector3_get_components @ This function returns the direction of a three-vector, i.e., a normalized three-vector. If the vector is null, we return a null vector. <>= public :: direction <>= interface direction module procedure vector3_get_direction end interface +<>= + elemental module function vector3_get_direction (p) result (q) + type(vector3_t) :: q + type(vector3_t), intent(in) :: p + end function vector3_get_direction <>= - elemental function vector3_get_direction (p) result (q) + elemental module function vector3_get_direction (p) result (q) type(vector3_t) :: q type(vector3_t), intent(in) :: p real(default) :: pp pp = p**1 if (pp > eps0) then q%p = p%p / pp else q%p = 0 end if end function vector3_get_direction @ %def direction @ \subsection{Four-vectors} In four-vectors the zero-component needs special treatment, therefore we do not use the standard operations. Sure, we pay for the extra layer of abstraction by losing efficiency; so we have to assume that the time-critical applications do not involve four-vector operations. <>= public :: vector4_t <>= type :: vector4_t real(default), dimension(0:3) :: p = & [zero, zero, zero, zero] contains <> end type vector4_t @ %def vector4_t @ Output a vector <>= public :: vector4_write <>= procedure :: write => vector4_write +<>= + module subroutine vector4_write & + (p, unit, show_mass, testflag, compressed, ultra) + class(vector4_t), intent(in) :: p + integer, intent(in), optional :: unit + logical, intent(in), optional :: show_mass, testflag, compressed, ultra + end subroutine vector4_write <>= - subroutine vector4_write & + module subroutine vector4_write & (p, unit, show_mass, testflag, compressed, ultra) class(vector4_t), intent(in) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass, testflag, compressed, ultra logical :: comp, sm, tf, extreme integer :: u character(len=7) :: fmt real(default) :: m comp = .false.; if (present (compressed)) comp = compressed sm = .false.; if (present (show_mass)) sm = show_mass tf = .false.; if (present (testflag)) tf = testflag extreme = .false.; if (present (ultra)) extreme = ultra if (extreme) then call pac_fmt (fmt, FMT_19, FMT_11, testflag) else call pac_fmt (fmt, FMT_19, FMT_13, testflag) end if u = given_output_unit (unit); if (u < 0) return if (comp) then write (u, "(4(F12.3,1X))", advance="no") p%p(0:3) else write (u, "(1x,A,1x," // fmt // ")") 'E = ', p%p(0) write (u, "(1x,A,3(1x," // fmt // "))") 'P = ', p%p(1:) if (sm) then m = p**1 if (tf) call pacify (m, tolerance = 1E-6_default) write (u, "(1x,A,1x," // fmt // ")") 'M = ', m end if end if end subroutine vector4_write @ %def vector4_write @ Binary I/O <>= public :: vector4_write_raw public :: vector4_read_raw +<>= + module subroutine vector4_write_raw (p, u) + type(vector4_t), intent(in) :: p + integer, intent(in) :: u + end subroutine vector4_write_raw + module subroutine vector4_read_raw (p, u, iostat) + type(vector4_t), intent(out) :: p + integer, intent(in) :: u + integer, intent(out), optional :: iostat + end subroutine vector4_read_raw <>= - subroutine vector4_write_raw (p, u) + module subroutine vector4_write_raw (p, u) type(vector4_t), intent(in) :: p integer, intent(in) :: u write (u) p%p end subroutine vector4_write_raw - subroutine vector4_read_raw (p, u, iostat) + module subroutine vector4_read_raw (p, u, iostat) type(vector4_t), intent(out) :: p integer, intent(in) :: u integer, intent(out), optional :: iostat read (u, iostat=iostat) p%p end subroutine vector4_read_raw @ %def vector4_write_raw vector4_read_raw @ This is a four-vector with zero components <>= public :: vector4_null <>= type(vector4_t), parameter :: vector4_null = & vector4_t ([ zero, zero, zero, zero ]) @ %def vector4_null @ Canonical four-vector: <>= public :: vector4_canonical +<>= + elemental module function vector4_canonical (k) result (p) + type(vector4_t) :: p + integer, intent(in) :: k + end function vector4_canonical <>= - elemental function vector4_canonical (k) result (p) + elemental module function vector4_canonical (k) result (p) type(vector4_t) :: p integer, intent(in) :: k p = vector4_null p%p(k) = 1 end function vector4_canonical @ %def vector4_canonical @ A particle at rest: <>= public :: vector4_at_rest +<>= + elemental module function vector4_at_rest (m) result (p) + type(vector4_t) :: p + real(default), intent(in) :: m + end function vector4_at_rest <>= - elemental function vector4_at_rest (m) result (p) + elemental module function vector4_at_rest (m) result (p) type(vector4_t) :: p real(default), intent(in) :: m p = vector4_t ([ m, zero, zero, zero ]) end function vector4_at_rest @ %def vector4_at_rest @ A moving particle ($k$-axis, or arbitrary axis) <>= public :: vector4_moving <>= interface vector4_moving module procedure vector4_moving_canonical module procedure vector4_moving_generic end interface +<>= + elemental module function vector4_moving_canonical (E, p, k) result (q) + type(vector4_t) :: q + real(default), intent(in) :: E, p + integer, intent(in) :: k + end function vector4_moving_canonical + elemental module function vector4_moving_generic (E, p) result (q) + type(vector4_t) :: q + real(default), intent(in) :: E + type(vector3_t), intent(in) :: p + end function vector4_moving_generic <>= - elemental function vector4_moving_canonical (E, p, k) result (q) + elemental module function vector4_moving_canonical (E, p, k) result (q) type(vector4_t) :: q real(default), intent(in) :: E, p integer, intent(in) :: k q = vector4_at_rest(E) q%p(k) = p end function vector4_moving_canonical - elemental function vector4_moving_generic (E, p) result (q) + elemental module function vector4_moving_generic (E, p) result (q) type(vector4_t) :: q real(default), intent(in) :: E type(vector3_t), intent(in) :: p q%p(0) = E q%p(1:) = p%p end function vector4_moving_generic @ %def vector4_moving @ Equality and inequality <>= interface operator(==) module procedure vector4_eq end interface interface operator(/=) module procedure vector4_neq end interface +<>= + elemental module function vector4_eq (p, q) result (r) + logical :: r + type(vector4_t), intent(in) :: p,q + end function vector4_eq + elemental module function vector4_neq (p, q) result (r) + logical :: r + type(vector4_t), intent(in) :: p,q + end function vector4_neq <>= - elemental function vector4_eq (p, q) result (r) + elemental module function vector4_eq (p, q) result (r) logical :: r type(vector4_t), intent(in) :: p,q r = all (abs (p%p - q%p) < eps0) end function vector4_eq - elemental function vector4_neq (p, q) result (r) + elemental module function vector4_neq (p, q) result (r) logical :: r type(vector4_t), intent(in) :: p,q r = any (abs (p%p - q%p) > eps0) end function vector4_neq @ %def == /= @ Addition and subtraction: <>= interface operator(+) module procedure add_vector4 end interface interface operator(-) module procedure sub_vector4 end interface +<>= + elemental module function add_vector4 (p,q) result (r) + type(vector4_t) :: r + type(vector4_t), intent(in) :: p,q + end function add_vector4 + elemental module function sub_vector4 (p,q) result (r) + type(vector4_t) :: r + type(vector4_t), intent(in) :: p,q + end function sub_vector4 <>= - elemental function add_vector4 (p,q) result (r) + elemental module function add_vector4 (p,q) result (r) type(vector4_t) :: r type(vector4_t), intent(in) :: p,q r%p = p%p + q%p end function add_vector4 - elemental function sub_vector4 (p,q) result (r) + elemental module function sub_vector4 (p,q) result (r) type(vector4_t) :: r type(vector4_t), intent(in) :: p,q r%p = p%p - q%p end function sub_vector4 @ %def + - @ We also need scalar multiplication and division: <>= interface operator(*) module procedure prod_real_vector4, prod_vector4_real module procedure prod_integer_vector4, prod_vector4_integer end interface interface operator(/) module procedure div_vector4_real module procedure div_vector4_integer end interface +<>= + elemental module function prod_real_vector4 (s, p) result (q) + type(vector4_t) :: q + real(default), intent(in) :: s + type(vector4_t), intent(in) :: p + end function prod_real_vector4 + elemental module function prod_vector4_real (p, s) result (q) + type(vector4_t) :: q + real(default), intent(in) :: s + type(vector4_t), intent(in) :: p + end function prod_vector4_real + elemental module function div_vector4_real (p, s) result (q) + type(vector4_t) :: q + real(default), intent(in) :: s + type(vector4_t), intent(in) :: p + end function div_vector4_real + elemental module function prod_integer_vector4 (s, p) result (q) + type(vector4_t) :: q + integer, intent(in) :: s + type(vector4_t), intent(in) :: p + end function prod_integer_vector4 + elemental module function prod_vector4_integer (p, s) result (q) + type(vector4_t) :: q + integer, intent(in) :: s + type(vector4_t), intent(in) :: p + end function prod_vector4_integer + elemental module function div_vector4_integer (p, s) result (q) + type(vector4_t) :: q + integer, intent(in) :: s + type(vector4_t), intent(in) :: p + end function div_vector4_integer <>= - elemental function prod_real_vector4 (s, p) result (q) + elemental module function prod_real_vector4 (s, p) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_real_vector4 - elemental function prod_vector4_real (p, s) result (q) + elemental module function prod_vector4_real (p, s) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_vector4_real - elemental function div_vector4_real (p, s) result (q) + elemental module function div_vector4_real (p, s) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p q%p = p%p/s end function div_vector4_real - elemental function prod_integer_vector4 (s, p) result (q) + elemental module function prod_integer_vector4 (s, p) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_integer_vector4 - elemental function prod_vector4_integer (p, s) result (q) + elemental module function prod_vector4_integer (p, s) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_vector4_integer - elemental function div_vector4_integer (p, s) result (q) + elemental module function div_vector4_integer (p, s) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p q%p = p%p/s end function div_vector4_integer @ %def * / @ Scalar products and squares in the Minkowski sense: <>= interface operator(*) module procedure prod_vector4 end interface interface operator(**) module procedure power_vector4 end interface +<>= + elemental module function prod_vector4 (p, q) result (s) + real(default) :: s + type(vector4_t), intent(in) :: p,q + end function prod_vector4 <>= - elemental function prod_vector4 (p, q) result (s) + elemental module function prod_vector4 (p, q) result (s) real(default) :: s type(vector4_t), intent(in) :: p,q s = p%p(0)*q%p(0) - dot_product(p%p(1:), q%p(1:)) end function prod_vector4 @ %def * @ The power operation for four-vectors is signed, i.e., [[p**1]] is positive for timelike and negative for spacelike vectors. Note that [[(p**1)**2]] is not necessarily equal to [[p**2]]. +<>= + elemental module function power_vector4 (p, e) result (s) + real(default) :: s + type(vector4_t), intent(in) :: p + integer, intent(in) :: e + end function power_vector4 <>= - elemental function power_vector4 (p, e) result (s) + elemental module function power_vector4 (p, e) result (s) real(default) :: s type(vector4_t), intent(in) :: p integer, intent(in) :: e s = p * p if (e /= 2) then if (mod(e, 2) == 0) then s = s**(e / 2) else if (s >= 0) then s = sqrt(s)**e else s = -(sqrt(abs(s))**e) end if end if end function power_vector4 @ %def ** @ Finally, we introduce a negation <>= interface operator(-) module procedure negate_vector4 end interface +<>= + elemental module function negate_vector4 (p) result (q) + type(vector4_t) :: q + type(vector4_t), intent(in) :: p + end function negate_vector4 <>= - elemental function negate_vector4 (p) result (q) + elemental module function negate_vector4 (p) result (q) type(vector4_t) :: q type(vector4_t), intent(in) :: p integer :: i do i = 0, 3 if (abs (p%p(i)) < eps0) then q%p(i) = 0 else q%p(i) = -p%p(i) end if end do end function negate_vector4 @ %def - @ The sum function can be useful: <>= interface sum module procedure sum_vector4, sum_vector4_mask end interface @ %def sum @ +<>= + pure module function sum_vector4 (p) result (q) + type(vector4_t) :: q + type(vector4_t), dimension(:), intent(in) :: p + end function sum_vector4 + pure module function sum_vector4_mask (p, mask) result (q) + type(vector4_t) :: q + type(vector4_t), dimension(:), intent(in) :: p + logical, dimension(:), intent(in) :: mask + end function sum_vector4_mask <>= - pure function sum_vector4 (p) result (q) + pure module function sum_vector4 (p) result (q) type(vector4_t) :: q type(vector4_t), dimension(:), intent(in) :: p integer :: i do i = 0, 3 q%p(i) = sum (p%p(i)) end do end function sum_vector4 - pure function sum_vector4_mask (p, mask) result (q) + pure module function sum_vector4_mask (p, mask) result (q) type(vector4_t) :: q type(vector4_t), dimension(:), intent(in) :: p logical, dimension(:), intent(in) :: mask integer :: i do i = 0, 3 q%p(i) = sum (p%p(i), mask=mask) end do end function sum_vector4_mask @ %def sum @ \subsection{Conversions} Manually set a component of the four-vector: <>= public :: vector4_set_component +<>= + module subroutine vector4_set_component (p, k, c) + type(vector4_t), intent(inout) :: p + integer, intent(in) :: k + real(default), intent(in) :: c + end subroutine vector4_set_component <>= - subroutine vector4_set_component (p, k, c) + module subroutine vector4_set_component (p, k, c) type(vector4_t), intent(inout) :: p integer, intent(in) :: k real(default), intent(in) :: c p%p(k) = c end subroutine vector4_set_component @ %def vector4_get_component Any component: <>= public :: vector4_get_component +<>= + elemental module function vector4_get_component (p, k) result (c) + real(default) :: c + type(vector4_t), intent(in) :: p + integer, intent(in) :: k + end function vector4_get_component <>= - elemental function vector4_get_component (p, k) result (c) + elemental module function vector4_get_component (p, k) result (c) real(default) :: c type(vector4_t), intent(in) :: p integer, intent(in) :: k c = p%p(k) end function vector4_get_component @ %def vector4_get_component @ Extract all components. This is not elemental. <>= public :: vector4_get_components +<>= + pure module function vector4_get_components (p) result (a) + real(default), dimension(0:3) :: a + type(vector4_t), intent(in) :: p + end function vector4_get_components <>= - pure function vector4_get_components (p) result (a) + pure module function vector4_get_components (p) result (a) real(default), dimension(0:3) :: a type(vector4_t), intent(in) :: p a = p%p end function vector4_get_components @ %def vector4_get_components @ This function returns the space part of a four-vector, such that we can apply three-vector operations on it: <>= public :: space_part <>= interface space_part module procedure vector4_get_space_part end interface +<>= + elemental module function vector4_get_space_part (p) result (q) + type(vector3_t) :: q + type(vector4_t), intent(in) :: p + end function vector4_get_space_part <>= - elemental function vector4_get_space_part (p) result (q) + elemental module function vector4_get_space_part (p) result (q) type(vector3_t) :: q type(vector4_t), intent(in) :: p q%p = p%p(1:) end function vector4_get_space_part @ %def space_part @ This function returns the direction of a four-vector, i.e., a normalized three-vector. If the four-vector has zero space part, we return a null vector. <>= interface direction module procedure vector4_get_direction end interface +<>= + elemental module function vector4_get_direction (p) result (q) + type(vector3_t) :: q + type(vector4_t), intent(in) :: p + end function vector4_get_direction <>= - elemental function vector4_get_direction (p) result (q) + elemental module function vector4_get_direction (p) result (q) type(vector3_t) :: q type(vector4_t), intent(in) :: p real(default) :: qq q%p = p%p(1:) qq = q**1 if (abs(qq) > eps0) then q%p = q%p / qq else q%p = 0 end if end function vector4_get_direction @ %def direction @ Change the sign of the spatial part of a four-vector <>= public :: vector4_invert_direction +<>= + elemental module subroutine vector4_invert_direction (p) + type(vector4_t), intent(inout) :: p + end subroutine vector4_invert_direction <>= - elemental subroutine vector4_invert_direction (p) + elemental module subroutine vector4_invert_direction (p) type(vector4_t), intent(inout) :: p p%p(1:3) = -p%p(1:3) end subroutine vector4_invert_direction @ %def vector4_invert_direction @ This function returns the four-vector as an ordinary array. A second version for an array of four-vectors. <>= public :: assignment (=) <>= interface assignment (=) module procedure array_from_vector4_1, array_from_vector4_2, & array_from_vector3_1, array_from_vector3_2, & vector4_from_array, vector3_from_array end interface +<>= + pure module subroutine array_from_vector4_1 (a, p) + real(default), dimension(:), intent(out) :: a + type(vector4_t), intent(in) :: p + end subroutine array_from_vector4_1 + pure module subroutine array_from_vector4_2 (a, p) + type(vector4_t), dimension(:), intent(in) :: p + real(default), dimension(:,:), intent(out) :: a + end subroutine array_from_vector4_2 + pure module subroutine array_from_vector3_1 (a, p) + real(default), dimension(:), intent(out) :: a + type(vector3_t), intent(in) :: p + end subroutine array_from_vector3_1 + pure module subroutine array_from_vector3_2 (a, p) + type(vector3_t), dimension(:), intent(in) :: p + real(default), dimension(:,:), intent(out) :: a + end subroutine array_from_vector3_2 + pure module subroutine vector4_from_array (p, a) + type(vector4_t), intent(out) :: p + real(default), dimension(:), intent(in) :: a + end subroutine vector4_from_array + pure module subroutine vector3_from_array (p, a) + type(vector3_t), intent(out) :: p + real(default), dimension(:), intent(in) :: a + end subroutine vector3_from_array <>= - pure subroutine array_from_vector4_1 (a, p) + pure module subroutine array_from_vector4_1 (a, p) real(default), dimension(:), intent(out) :: a type(vector4_t), intent(in) :: p a = p%p end subroutine array_from_vector4_1 - pure subroutine array_from_vector4_2 (a, p) + pure module subroutine array_from_vector4_2 (a, p) type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:,:), intent(out) :: a integer :: i forall (i=1:size(p)) a(:,i) = p(i)%p end forall end subroutine array_from_vector4_2 - pure subroutine array_from_vector3_1 (a, p) + pure module subroutine array_from_vector3_1 (a, p) real(default), dimension(:), intent(out) :: a type(vector3_t), intent(in) :: p a = p%p end subroutine array_from_vector3_1 - pure subroutine array_from_vector3_2 (a, p) + pure module subroutine array_from_vector3_2 (a, p) type(vector3_t), dimension(:), intent(in) :: p real(default), dimension(:,:), intent(out) :: a integer :: i forall (i=1:size(p)) a(:,i) = p(i)%p end forall end subroutine array_from_vector3_2 - pure subroutine vector4_from_array (p, a) + pure module subroutine vector4_from_array (p, a) type(vector4_t), intent(out) :: p real(default), dimension(:), intent(in) :: a p%p(0:3) = a end subroutine vector4_from_array - pure subroutine vector3_from_array (p, a) + pure module subroutine vector3_from_array (p, a) type(vector3_t), intent(out) :: p real(default), dimension(:), intent(in) :: a p%p(1:3) = a end subroutine vector3_from_array @ %def array_from_vector4 array_from_vector3 @ <>= public :: vector4 +<>= + pure module function vector4 (a) result (p) + type(vector4_t) :: p + real(default), intent(in), dimension(4) :: a + end function vector4 <>= - pure function vector4 (a) result (p) + pure module function vector4 (a) result (p) type(vector4_t) :: p real(default), intent(in), dimension(4) :: a p%p = a end function vector4 @ %def vector4 @ <>= procedure :: to_pythia6 => vector4_to_pythia6 +<>= + pure module function vector4_to_pythia6 (vector4, m) result (p) + real(double), dimension(1:5) :: p + class(vector4_t), intent(in) :: vector4 + real(default), intent(in), optional :: m + end function vector4_to_pythia6 <>= - pure function vector4_to_pythia6 (vector4, m) result (p) + pure module function vector4_to_pythia6 (vector4, m) result (p) real(double), dimension(1:5) :: p class(vector4_t), intent(in) :: vector4 real(default), intent(in), optional :: m p(1:3) = vector4%p(1:3) p(4) = vector4%p(0) if (present (m)) then p(5) = m else p(5) = vector4 ** 1 end if end function vector4_to_pythia6 @ %def vector4_to_pythia6 @ \subsection{Interface to [[c_prt]]} Transform the momentum of a [[c_prt]] object into a four-vector and vice versa: <>= interface assignment (=) module procedure vector4_from_c_prt, c_prt_from_vector4 end interface +<>= + pure module subroutine vector4_from_c_prt (p, c_prt) + type(vector4_t), intent(out) :: p + type(c_prt_t), intent(in) :: c_prt + end subroutine vector4_from_c_prt + pure module subroutine c_prt_from_vector4 (c_prt, p) + type(c_prt_t), intent(out) :: c_prt + type(vector4_t), intent(in) :: p + end subroutine c_prt_from_vector4 <>= - pure subroutine vector4_from_c_prt (p, c_prt) + pure module subroutine vector4_from_c_prt (p, c_prt) type(vector4_t), intent(out) :: p type(c_prt_t), intent(in) :: c_prt p%p(0) = c_prt%pe p%p(1) = c_prt%px p%p(2) = c_prt%py p%p(3) = c_prt%pz end subroutine vector4_from_c_prt - pure subroutine c_prt_from_vector4 (c_prt, p) + pure module subroutine c_prt_from_vector4 (c_prt, p) type(c_prt_t), intent(out) :: c_prt type(vector4_t), intent(in) :: p c_prt%pe = p%p(0) c_prt%px = p%p(1) c_prt%py = p%p(2) c_prt%pz = p%p(3) c_prt%p2 = p ** 2 end subroutine c_prt_from_vector4 @ %def vector4_from_c_prt c_prt_from_vector4 @ Initialize a [[c_prt_t]] object with the components of a four-vector as its kinematical entries. Compute the invariant mass, or use the optional mass-squared value instead. <>= public :: vector4_to_c_prt +<>= + elemental module function vector4_to_c_prt (p, p2) result (c_prt) + type(c_prt_t) :: c_prt + type(vector4_t), intent(in) :: p + real(default), intent(in), optional :: p2 + end function vector4_to_c_prt <>= - elemental function vector4_to_c_prt (p, p2) result (c_prt) + elemental module function vector4_to_c_prt (p, p2) result (c_prt) type(c_prt_t) :: c_prt type(vector4_t), intent(in) :: p real(default), intent(in), optional :: p2 c_prt%pe = p%p(0) c_prt%px = p%p(1) c_prt%py = p%p(2) c_prt%pz = p%p(3) if (present (p2)) then c_prt%p2 = p2 else c_prt%p2 = p ** 2 end if end function vector4_to_c_prt @ %def vector4_to_c_prt @ \subsection{Angles} Return the angles in a canonical system. The angle $\phi$ is defined between $0\leq\phi<2\pi$. In degenerate cases, return zero. <>= public :: azimuthal_angle <>= interface azimuthal_angle module procedure vector3_azimuthal_angle module procedure vector4_azimuthal_angle end interface +<>= + elemental module function vector3_azimuthal_angle (p) result (phi) + real(default) :: phi + type(vector3_t), intent(in) :: p + end function vector3_azimuthal_angle + elemental module function vector4_azimuthal_angle (p) result (phi) + real(default) :: phi + type(vector4_t), intent(in) :: p + end function vector4_azimuthal_angle <>= - elemental function vector3_azimuthal_angle (p) result (phi) + elemental module function vector3_azimuthal_angle (p) result (phi) real(default) :: phi type(vector3_t), intent(in) :: p if (any (abs (p%p(1:2)) > 0)) then phi = atan2(p%p(2), p%p(1)) if (phi < 0) phi = phi + twopi else phi = 0 end if end function vector3_azimuthal_angle - elemental function vector4_azimuthal_angle (p) result (phi) + elemental module function vector4_azimuthal_angle (p) result (phi) real(default) :: phi type(vector4_t), intent(in) :: p phi = vector3_azimuthal_angle (space_part (p)) end function vector4_azimuthal_angle @ %def azimuthal_angle @ Azimuthal angle in degrees <>= public :: azimuthal_angle_deg <>= interface azimuthal_angle_deg module procedure vector3_azimuthal_angle_deg module procedure vector4_azimuthal_angle_deg end interface +<>= + elemental module function vector3_azimuthal_angle_deg (p) result (phi) + real(default) :: phi + type(vector3_t), intent(in) :: p + end function vector3_azimuthal_angle_deg + elemental module function vector4_azimuthal_angle_deg (p) result (phi) + real(default) :: phi + type(vector4_t), intent(in) :: p + end function vector4_azimuthal_angle_deg <>= - elemental function vector3_azimuthal_angle_deg (p) result (phi) + elemental module function vector3_azimuthal_angle_deg (p) result (phi) real(default) :: phi type(vector3_t), intent(in) :: p phi = vector3_azimuthal_angle (p) / degree end function vector3_azimuthal_angle_deg - elemental function vector4_azimuthal_angle_deg (p) result (phi) + elemental module function vector4_azimuthal_angle_deg (p) result (phi) real(default) :: phi type(vector4_t), intent(in) :: p phi = vector4_azimuthal_angle (p) / degree end function vector4_azimuthal_angle_deg @ %def azimuthal_angle_deg @ The azimuthal distance of two vectors. This is the difference of the azimuthal angles, but cannot be larger than $\pi$: The result is between $-\pi<\Delta\phi\leq\pi$. <>= public :: azimuthal_distance <>= interface azimuthal_distance module procedure vector3_azimuthal_distance module procedure vector4_azimuthal_distance end interface +<>= + elemental module function vector3_azimuthal_distance (p, q) result (dphi) + real(default) :: dphi + type(vector3_t), intent(in) :: p,q + end function vector3_azimuthal_distance + elemental module function vector4_azimuthal_distance (p, q) result (dphi) + real(default) :: dphi + type(vector4_t), intent(in) :: p,q + end function vector4_azimuthal_distance <>= - elemental function vector3_azimuthal_distance (p, q) result (dphi) + elemental module function vector3_azimuthal_distance (p, q) result (dphi) real(default) :: dphi type(vector3_t), intent(in) :: p,q dphi = vector3_azimuthal_angle (q) - vector3_azimuthal_angle (p) if (dphi <= -pi) then dphi = dphi + twopi else if (dphi > pi) then dphi = dphi - twopi end if end function vector3_azimuthal_distance - elemental function vector4_azimuthal_distance (p, q) result (dphi) + elemental module function vector4_azimuthal_distance (p, q) result (dphi) real(default) :: dphi type(vector4_t), intent(in) :: p,q dphi = vector3_azimuthal_distance & (space_part (p), space_part (q)) end function vector4_azimuthal_distance @ %def azimuthal_distance @ The same in degrees: <>= public :: azimuthal_distance_deg <>= interface azimuthal_distance_deg module procedure vector3_azimuthal_distance_deg module procedure vector4_azimuthal_distance_deg end interface +<>= + elemental module function vector3_azimuthal_distance_deg (p, q) result (dphi) + real(default) :: dphi + type(vector3_t), intent(in) :: p,q + end function vector3_azimuthal_distance_deg + elemental module function vector4_azimuthal_distance_deg (p, q) result (dphi) + real(default) :: dphi + type(vector4_t), intent(in) :: p,q + end function vector4_azimuthal_distance_deg <>= - elemental function vector3_azimuthal_distance_deg (p, q) result (dphi) + elemental module function vector3_azimuthal_distance_deg (p, q) result (dphi) real(default) :: dphi type(vector3_t), intent(in) :: p,q dphi = vector3_azimuthal_distance (p, q) / degree end function vector3_azimuthal_distance_deg - elemental function vector4_azimuthal_distance_deg (p, q) result (dphi) + elemental module function vector4_azimuthal_distance_deg (p, q) result (dphi) real(default) :: dphi type(vector4_t), intent(in) :: p,q dphi = vector4_azimuthal_distance (p, q) / degree end function vector4_azimuthal_distance_deg @ %def azimuthal_distance_deg @ The polar angle is defined $0\leq\theta\leq\pi$. Note that [[ATAN2]] has the reversed order of arguments: [[ATAN2(Y,X)]]. Here, $x$ is the 3-component while $y$ is the transverse momentum which is always nonnegative. Therefore, the result is nonnegative as well. <>= public :: polar_angle <>= interface polar_angle module procedure polar_angle_vector3 module procedure polar_angle_vector4 end interface +<>= + elemental module function polar_angle_vector3 (p) result (theta) + real(default) :: theta + type(vector3_t), intent(in) :: p + end function polar_angle_vector3 + elemental module function polar_angle_vector4 (p) result (theta) + real(default) :: theta + type(vector4_t), intent(in) :: p + end function polar_angle_vector4 <>= - elemental function polar_angle_vector3 (p) result (theta) + elemental module function polar_angle_vector3 (p) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p if (any (abs (p%p) > 0)) then theta = atan2 (sqrt(p%p(1)**2 + p%p(2)**2), p%p(3)) else theta = 0 end if end function polar_angle_vector3 - elemental function polar_angle_vector4 (p) result (theta) + elemental module function polar_angle_vector4 (p) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p theta = polar_angle (space_part (p)) end function polar_angle_vector4 @ %def polar_angle @ This is the cosine of the polar angle: $-1\leq\cos\theta\leq 1$. <>= public :: polar_angle_ct <>= interface polar_angle_ct module procedure polar_angle_ct_vector3 module procedure polar_angle_ct_vector4 end interface +<>= + elemental module function polar_angle_ct_vector3 (p) result (ct) + real(default) :: ct + type(vector3_t), intent(in) :: p + end function polar_angle_ct_vector3 + elemental module function polar_angle_ct_vector4 (p) result (ct) + real(default) :: ct + type(vector4_t), intent(in) :: p + end function polar_angle_ct_vector4 <>= - elemental function polar_angle_ct_vector3 (p) result (ct) + elemental module function polar_angle_ct_vector3 (p) result (ct) real(default) :: ct type(vector3_t), intent(in) :: p if (any (abs (p%p) > 0)) then ct = p%p(3) / p**1 else ct = 1 end if end function polar_angle_ct_vector3 - elemental function polar_angle_ct_vector4 (p) result (ct) + elemental module function polar_angle_ct_vector4 (p) result (ct) real(default) :: ct type(vector4_t), intent(in) :: p ct = polar_angle_ct (space_part (p)) end function polar_angle_ct_vector4 @ %def polar_angle_ct @ The polar angle in degrees. <>= public :: polar_angle_deg <>= interface polar_angle_deg module procedure polar_angle_deg_vector3 module procedure polar_angle_deg_vector4 end interface +<>= + elemental module function polar_angle_deg_vector3 (p) result (theta) + real(default) :: theta + type(vector3_t), intent(in) :: p + end function polar_angle_deg_vector3 + elemental module function polar_angle_deg_vector4 (p) result (theta) + real(default) :: theta + type(vector4_t), intent(in) :: p + end function polar_angle_deg_vector4 <>= - elemental function polar_angle_deg_vector3 (p) result (theta) + elemental module function polar_angle_deg_vector3 (p) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p theta = polar_angle (p) / degree end function polar_angle_deg_vector3 - elemental function polar_angle_deg_vector4 (p) result (theta) + elemental module function polar_angle_deg_vector4 (p) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p theta = polar_angle (p) / degree end function polar_angle_deg_vector4 @ %def polar_angle_deg @ This is the angle enclosed between two three-momenta. If one of the momenta is zero, we return an angle of zero. The range of the result is $0\leq\theta\leq\pi$. If there is only one argument, take the positive $z$ axis as reference. <>= public :: enclosed_angle <>= interface enclosed_angle module procedure enclosed_angle_vector3 module procedure enclosed_angle_vector4 end interface +<>= + elemental module function enclosed_angle_vector3 (p, q) result (theta) + real(default) :: theta + type(vector3_t), intent(in) :: p, q + end function enclosed_angle_vector3 + elemental module function enclosed_angle_vector4 (p, q) result (theta) + real(default) :: theta + type(vector4_t), intent(in) :: p, q + end function enclosed_angle_vector4 <>= - elemental function enclosed_angle_vector3 (p, q) result (theta) + elemental module function enclosed_angle_vector3 (p, q) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p, q theta = acos (enclosed_angle_ct (p, q)) end function enclosed_angle_vector3 - elemental function enclosed_angle_vector4 (p, q) result (theta) + elemental module function enclosed_angle_vector4 (p, q) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p, q theta = enclosed_angle (space_part (p), space_part (q)) end function enclosed_angle_vector4 @ %def enclosed_angle @ The cosine of the enclosed angle. <>= public :: enclosed_angle_ct <>= interface enclosed_angle_ct module procedure enclosed_angle_ct_vector3 module procedure enclosed_angle_ct_vector4 end interface +<>= + elemental module function enclosed_angle_ct_vector3 (p, q) result (ct) + real(default) :: ct + type(vector3_t), intent(in) :: p, q + end function enclosed_angle_ct_vector3 + elemental module function enclosed_angle_ct_vector4 (p, q) result (ct) + real(default) :: ct + type(vector4_t), intent(in) :: p, q + end function enclosed_angle_ct_vector4 <>= - elemental function enclosed_angle_ct_vector3 (p, q) result (ct) + elemental module function enclosed_angle_ct_vector3 (p, q) result (ct) real(default) :: ct type(vector3_t), intent(in) :: p, q if (any (abs (p%p) > 0) .and. any (abs (q%p) > 0)) then ct = p*q / (p**1 * q**1) if (ct>1) then ct = 1 else if (ct<-1) then ct = -1 end if else ct = 1 end if end function enclosed_angle_ct_vector3 - elemental function enclosed_angle_ct_vector4 (p, q) result (ct) + elemental module function enclosed_angle_ct_vector4 (p, q) result (ct) real(default) :: ct type(vector4_t), intent(in) :: p, q ct = enclosed_angle_ct (space_part (p), space_part (q)) end function enclosed_angle_ct_vector4 @ %def enclosed_angle_ct @ The enclosed angle in degrees. <>= public :: enclosed_angle_deg <>= interface enclosed_angle_deg module procedure enclosed_angle_deg_vector3 module procedure enclosed_angle_deg_vector4 end interface +<>= + elemental module function enclosed_angle_deg_vector3 (p, q) result (theta) + real(default) :: theta + type(vector3_t), intent(in) :: p, q + end function enclosed_angle_deg_vector3 + elemental module function enclosed_angle_deg_vector4 (p, q) result (theta) + real(default) :: theta + type(vector4_t), intent(in) :: p, q + end function enclosed_angle_deg_vector4 <>= - elemental function enclosed_angle_deg_vector3 (p, q) result (theta) + elemental module function enclosed_angle_deg_vector3 (p, q) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p, q theta = enclosed_angle (p, q) / degree end function enclosed_angle_deg_vector3 - elemental function enclosed_angle_deg_vector4 (p, q) result (theta) + elemental module function enclosed_angle_deg_vector4 (p, q) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p, q theta = enclosed_angle (p, q) / degree end function enclosed_angle_deg_vector4 @ %def enclosed_angle @ The polar angle of the first momentum w.r.t.\ the second momentum, evaluated in the rest frame of the second momentum. If the second four-momentum is not timelike, return zero. <>= public :: enclosed_angle_rest_frame public :: enclosed_angle_ct_rest_frame public :: enclosed_angle_deg_rest_frame <>= interface enclosed_angle_rest_frame module procedure enclosed_angle_rest_frame_vector4 end interface interface enclosed_angle_ct_rest_frame module procedure enclosed_angle_ct_rest_frame_vector4 end interface interface enclosed_angle_deg_rest_frame module procedure enclosed_angle_deg_rest_frame_vector4 end interface +<>= + elemental module function enclosed_angle_rest_frame_vector4 (p, q) result (theta) + type(vector4_t), intent(in) :: p, q + real(default) :: theta + end function enclosed_angle_rest_frame_vector4 + elemental module function enclosed_angle_ct_rest_frame_vector4 (p, q) result (ct) + type(vector4_t), intent(in) :: p, q + real(default) :: ct + end function enclosed_angle_ct_rest_frame_vector4 + elemental module function enclosed_angle_deg_rest_frame_vector4 (p, q) & + result (theta) + type(vector4_t), intent(in) :: p, q + real(default) :: theta + end function enclosed_angle_deg_rest_frame_vector4 <>= - elemental function enclosed_angle_rest_frame_vector4 (p, q) result (theta) + elemental module function enclosed_angle_rest_frame_vector4 (p, q) result (theta) type(vector4_t), intent(in) :: p, q real(default) :: theta theta = acos (enclosed_angle_ct_rest_frame (p, q)) end function enclosed_angle_rest_frame_vector4 - elemental function enclosed_angle_ct_rest_frame_vector4 (p, q) result (ct) + elemental module function enclosed_angle_ct_rest_frame_vector4 (p, q) result (ct) type(vector4_t), intent(in) :: p, q real(default) :: ct if (invariant_mass(q) > 0) then ct = enclosed_angle_ct ( & space_part (boost(-q, invariant_mass (q)) * p), & space_part (q)) else ct = 1 end if end function enclosed_angle_ct_rest_frame_vector4 - elemental function enclosed_angle_deg_rest_frame_vector4 (p, q) & + elemental module function enclosed_angle_deg_rest_frame_vector4 (p, q) & result (theta) type(vector4_t), intent(in) :: p, q real(default) :: theta theta = enclosed_angle_rest_frame (p, q) / degree end function enclosed_angle_deg_rest_frame_vector4 @ %def enclosed_angle_rest_frame @ %def enclosed_angle_ct_rest_frame @ %def enclosed_angle_deg_rest_frame @ \subsection{More kinematical functions (some redundant)} The scalar transverse momentum (assuming the $z$ axis is longitudinal) <>= public :: transverse_part <>= interface transverse_part module procedure transverse_part_vector4_beam_axis module procedure transverse_part_vector4_vector4 end interface +<>= + elemental module function transverse_part_vector4_beam_axis (p) result (pT) + real(default) :: pT + type(vector4_t), intent(in) :: p + end function transverse_part_vector4_beam_axis + elemental module function transverse_part_vector4_vector4 (p1, p2) result (pT) + real(default) :: pT + type(vector4_t), intent(in) :: p1, p2 + end function transverse_part_vector4_vector4 <>= - elemental function transverse_part_vector4_beam_axis (p) result (pT) + elemental module function transverse_part_vector4_beam_axis (p) result (pT) real(default) :: pT type(vector4_t), intent(in) :: p pT = sqrt(p%p(1)**2 + p%p(2)**2) end function transverse_part_vector4_beam_axis - elemental function transverse_part_vector4_vector4 (p1, p2) result (pT) + elemental module function transverse_part_vector4_vector4 (p1, p2) result (pT) real(default) :: pT type(vector4_t), intent(in) :: p1, p2 real(default) :: p1_norm, p2_norm, p1p2, pT2 p1_norm = space_part_norm(p1)**2 p2_norm = space_part_norm(p2)**2 ! p1p2 = p1%p(1:3)*p2%p(1:3) p1p2 = vector4_get_space_part(p1) * vector4_get_space_part(p2) pT2 = (p1_norm*p2_norm - p1p2)/p1_norm pT = sqrt (pT2) end function transverse_part_vector4_vector4 @ %def transverse_part @ The scalar longitudinal momentum (assuming the $z$ axis is longitudinal). Identical to [[momentum_z_component]]. <>= public :: longitudinal_part <>= interface longitudinal_part module procedure longitudinal_part_vector4 end interface +<>= + elemental module function longitudinal_part_vector4 (p) result (pL) + real(default) :: pL + type(vector4_t), intent(in) :: p + end function longitudinal_part_vector4 <>= - elemental function longitudinal_part_vector4 (p) result (pL) + elemental module function longitudinal_part_vector4 (p) result (pL) real(default) :: pL type(vector4_t), intent(in) :: p pL = p%p(3) end function longitudinal_part_vector4 @ %def longitudinal_part @ Absolute value of three-momentum <>= public :: space_part_norm <>= interface space_part_norm module procedure space_part_norm_vector4 end interface +<>= + elemental module function space_part_norm_vector4 (p) result (p3) + real(default) :: p3 + type(vector4_t), intent(in) :: p + end function space_part_norm_vector4 <>= - elemental function space_part_norm_vector4 (p) result (p3) + elemental module function space_part_norm_vector4 (p) result (p3) real(default) :: p3 type(vector4_t), intent(in) :: p p3 = sqrt (p%p(1)**2 + p%p(2)**2 + p%p(3)**2) end function space_part_norm_vector4 @ %def momentum @ The energy (the zeroth component) <>= public :: energy <>= interface energy module procedure energy_vector4 module procedure energy_vector3 module procedure energy_real end interface +<>= + elemental module function energy_vector4 (p) result (E) + real(default) :: E + type(vector4_t), intent(in) :: p + end function energy_vector4 + elemental module function energy_vector3 (p, mass) result (E) + real(default) :: E + type(vector3_t), intent(in) :: p + real(default), intent(in), optional :: mass + end function energy_vector3 + elemental module function energy_real (p, mass) result (E) + real(default) :: E + real(default), intent(in) :: p + real(default), intent(in), optional :: mass + end function energy_real <>= - elemental function energy_vector4 (p) result (E) + elemental module function energy_vector4 (p) result (E) real(default) :: E type(vector4_t), intent(in) :: p E = p%p(0) end function energy_vector4 @ Alternative: The energy corresponding to a given momentum and mass. If the mass is omitted, it is zero <>= - elemental function energy_vector3 (p, mass) result (E) + elemental module function energy_vector3 (p, mass) result (E) real(default) :: E type(vector3_t), intent(in) :: p real(default), intent(in), optional :: mass if (present (mass)) then E = sqrt (p**2 + mass**2) else E = p**1 end if end function energy_vector3 - elemental function energy_real (p, mass) result (E) + elemental module function energy_real (p, mass) result (E) real(default) :: E real(default), intent(in) :: p real(default), intent(in), optional :: mass if (present (mass)) then E = sqrt (p**2 + mass**2) else E = abs (p) end if end function energy_real @ %def energy @ The invariant mass of four-momenta. Zero for lightlike, negative for spacelike momenta. <>= public :: invariant_mass <>= interface invariant_mass module procedure invariant_mass_vector4 end interface +<>= + elemental module function invariant_mass_vector4 (p) result (m) + real(default) :: m + type(vector4_t), intent(in) :: p + end function invariant_mass_vector4 <>= - elemental function invariant_mass_vector4 (p) result (m) + elemental module function invariant_mass_vector4 (p) result (m) real(default) :: m type(vector4_t), intent(in) :: p real(default) :: msq msq = p*p if (msq >= 0) then m = sqrt (msq) else m = - sqrt (abs (msq)) end if end function invariant_mass_vector4 @ %def invariant_mass - @ The invariant mass squared. Zero for lightlike, negative for spacelike momenta. <>= public :: invariant_mass_squared <>= interface invariant_mass_squared module procedure invariant_mass_squared_vector4 end interface +<>= + elemental module function invariant_mass_squared_vector4 (p) result (msq) + real(default) :: msq + type(vector4_t), intent(in) :: p + end function invariant_mass_squared_vector4 <>= - elemental function invariant_mass_squared_vector4 (p) result (msq) + elemental module function invariant_mass_squared_vector4 (p) result (msq) real(default) :: msq type(vector4_t), intent(in) :: p msq = p*p end function invariant_mass_squared_vector4 @ %def invariant_mass_squared @ The transverse mass. If the mass squared is negative, this value also is negative. <>= public :: transverse_mass <>= interface transverse_mass module procedure transverse_mass_vector4 end interface +<>= + elemental module function transverse_mass_vector4 (p) result (m) + real(default) :: m + type(vector4_t), intent(in) :: p + end function transverse_mass_vector4 <>= - elemental function transverse_mass_vector4 (p) result (m) + elemental module function transverse_mass_vector4 (p) result (m) real(default) :: m type(vector4_t), intent(in) :: p real(default) :: msq msq = p%p(0)**2 - p%p(1)**2 - p%p(2)**2 if (msq >= 0) then m = sqrt (msq) else m = - sqrt (abs (msq)) end if end function transverse_mass_vector4 @ %def transverse_mass @ The rapidity (defined if particle is massive or $p_\perp>0$) <>= public :: rapidity <>= interface rapidity module procedure rapidity_vector4 end interface +<>= + elemental module function rapidity_vector4 (p) result (y) + real(default) :: y + type(vector4_t), intent(in) :: p + end function rapidity_vector4 <>= - elemental function rapidity_vector4 (p) result (y) + elemental module function rapidity_vector4 (p) result (y) real(default) :: y type(vector4_t), intent(in) :: p y = .5 * log( (energy (p) + longitudinal_part (p)) & & /(energy (p) - longitudinal_part (p))) end function rapidity_vector4 @ %def rapidity @ The pseudorapidity (defined if $p_\perp>0$) <>= public :: pseudorapidity <>= interface pseudorapidity module procedure pseudorapidity_vector4 end interface +<>= + elemental module function pseudorapidity_vector4 (p) result (eta) + real(default) :: eta + type(vector4_t), intent(in) :: p + end function pseudorapidity_vector4 <>= - elemental function pseudorapidity_vector4 (p) result (eta) + elemental module function pseudorapidity_vector4 (p) result (eta) real(default) :: eta type(vector4_t), intent(in) :: p eta = -log( tan (.5 * polar_angle (p))) end function pseudorapidity_vector4 @ %def pseudorapidity @ The rapidity distance (defined if both $p_\perp>0$) <>= public :: rapidity_distance <>= interface rapidity_distance module procedure rapidity_distance_vector4 end interface +<>= + elemental module function rapidity_distance_vector4 (p, q) result (dy) + type(vector4_t), intent(in) :: p, q + real(default) :: dy + end function rapidity_distance_vector4 <>= - elemental function rapidity_distance_vector4 (p, q) result (dy) + elemental module function rapidity_distance_vector4 (p, q) result (dy) type(vector4_t), intent(in) :: p, q real(default) :: dy dy = rapidity (q) - rapidity (p) end function rapidity_distance_vector4 @ %def rapidity_distance @ The pseudorapidity distance (defined if both $p_\perp>0$) <>= public :: pseudorapidity_distance <>= interface pseudorapidity_distance module procedure pseudorapidity_distance_vector4 end interface +<>= + elemental module function pseudorapidity_distance_vector4 (p, q) result (deta) + real(default) :: deta + type(vector4_t), intent(in) :: p, q + end function pseudorapidity_distance_vector4 <>= - elemental function pseudorapidity_distance_vector4 (p, q) result (deta) + elemental module function pseudorapidity_distance_vector4 (p, q) result (deta) real(default) :: deta type(vector4_t), intent(in) :: p, q deta = pseudorapidity (q) - pseudorapidity (p) end function pseudorapidity_distance_vector4 @ %def pseudorapidity_distance @ The distance on the $\eta-\phi$ cylinder: <>= public :: eta_phi_distance <>= interface eta_phi_distance module procedure eta_phi_distance_vector4 end interface +<>= + elemental module function eta_phi_distance_vector4 (p, q) result (dr) + type(vector4_t), intent(in) :: p, q + real(default) :: dr + end function eta_phi_distance_vector4 <>= - elemental function eta_phi_distance_vector4 (p, q) result (dr) + elemental module function eta_phi_distance_vector4 (p, q) result (dr) type(vector4_t), intent(in) :: p, q real(default) :: dr dr = sqrt ( & pseudorapidity_distance (p, q)**2 & + azimuthal_distance (p, q)**2) end function eta_phi_distance_vector4 @ %def eta_phi_distance @ \subsection{Lorentz transformations} <>= public :: lorentz_transformation_t <>= type :: lorentz_transformation_t private real(default), dimension(0:3, 0:3) :: L contains <> end type lorentz_transformation_t @ %def lorentz_transformation_t @ Output: <>= public :: lorentz_transformation_write <>= procedure :: write => lorentz_transformation_write +<>= + module subroutine lorentz_transformation_write (L, unit, testflag, ultra) + class(lorentz_transformation_t), intent(in) :: L + integer, intent(in), optional :: unit + logical, intent(in), optional :: testflag, ultra + end subroutine lorentz_transformation_write <>= - subroutine lorentz_transformation_write (L, unit, testflag, ultra) + module subroutine lorentz_transformation_write (L, unit, testflag, ultra) class(lorentz_transformation_t), intent(in) :: L integer, intent(in), optional :: unit logical, intent(in), optional :: testflag, ultra integer :: u, i logical :: ult character(len=7) :: fmt ult = .false.; if (present (ultra)) ult = ultra if (ult) then call pac_fmt (fmt, FMT_19, FMT_11, ultra) else call pac_fmt (fmt, FMT_19, FMT_13, testflag) end if u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A,3(1x," // fmt // "))") "L00 = ", L%L(0,0) write (u, "(1x,A,3(1x," // fmt // "))") "L0j = ", L%L(0,1:3) do i = 1, 3 write (u, "(1x,A,I0,A,3(1x," // fmt // "))") & "L", i, "0 = ", L%L(i,0) write (u, "(1x,A,I0,A,3(1x," // fmt // "))") & "L", i, "j = ", L%L(i,1:3) end do end subroutine lorentz_transformation_write @ %def lorentz_transformation_write @ Extract all components: <>= public :: lorentz_transformation_get_components +<>= + pure module function lorentz_transformation_get_components (L) result (a) + type(lorentz_transformation_t), intent(in) :: L + real(default), dimension(0:3,0:3) :: a + end function lorentz_transformation_get_components <>= - pure function lorentz_transformation_get_components (L) result (a) + pure module function lorentz_transformation_get_components (L) result (a) type(lorentz_transformation_t), intent(in) :: L real(default), dimension(0:3,0:3) :: a a = L%L end function lorentz_transformation_get_components @ %def lorentz_transformation_get_components @ \subsection{Functions of Lorentz transformations} For the inverse, we make use of the fact that $\Lambda^{\mu\nu}\Lambda_{\mu\rho}=\delta^\nu_\rho$. So, lowering the indices and transposing is sufficient. <>= public :: inverse <>= interface inverse module procedure lorentz_transformation_inverse end interface +<>= + elemental module function lorentz_transformation_inverse (L) result (IL) + type(lorentz_transformation_t) :: IL + type(lorentz_transformation_t), intent(in) :: L + end function lorentz_transformation_inverse <>= - elemental function lorentz_transformation_inverse (L) result (IL) + elemental module function lorentz_transformation_inverse (L) result (IL) type(lorentz_transformation_t) :: IL type(lorentz_transformation_t), intent(in) :: L IL%L(0,0) = L%L(0,0) IL%L(0,1:) = -L%L(1:,0) IL%L(1:,0) = -L%L(0,1:) IL%L(1:,1:) = transpose(L%L(1:,1:)) end function lorentz_transformation_inverse @ %def lorentz_transformation_inverse @ %def inverse @ \subsection{Invariants} These are used below. The first array index is varying fastest in [[FORTRAN]]; therefore the extra minus in the odd-rank tensor epsilon. <>= integer, dimension(3,3), parameter :: delta_three = & & reshape( source = [ 1,0,0, 0,1,0, 0,0,1 ], & & shape = [3,3] ) integer, dimension(3,3,3), parameter :: epsilon_three = & & reshape( source = [ 0, 0,0, 0,0,-1, 0,1,0, & & 0, 0,1, 0,0, 0, -1,0,0, & & 0,-1,0, 1,0, 0, 0,0,0 ],& & shape = [3,3,3] ) @ %def delta_three epsilon_three @ This could be of some use: <>= public :: identity <>= type(lorentz_transformation_t), parameter :: & & identity = & & lorentz_transformation_t ( & & reshape( source = [ one, zero, zero, zero, & & zero, one, zero, zero, & & zero, zero, one, zero, & & zero, zero, zero, one ],& & shape = [4,4] ) ) @ %def identity <>= public :: space_reflection <>= type(lorentz_transformation_t), parameter :: & & space_reflection = & & lorentz_transformation_t ( & & reshape( source = [ one, zero, zero, zero, & & zero,-one, zero, zero, & & zero, zero,-one, zero, & & zero, zero, zero,-one ],& & shape = [4,4] ) ) @ %def space_reflection @ Builds a unit vector orthogal to the input vector in the xy-plane. <>= public :: create_orthogonal +<>= + module function create_orthogonal (p_in) result (p_out) + type(vector3_t), intent(in) :: p_in + type(vector3_t) :: p_out + end function create_orthogonal <>= - function create_orthogonal (p_in) result (p_out) + module function create_orthogonal (p_in) result (p_out) type(vector3_t), intent(in) :: p_in type(vector3_t) :: p_out real(default) :: ab ab = sqrt (p_in%p(1)**2 + p_in%p(2)**2) if (abs (ab) < eps0) then p_out%p(1) = 1 p_out%p(2) = 0 p_out%p(3) = 0 else p_out%p(1) = p_in%p(2) p_out%p(2) = -p_in%p(1) p_out%p(3) = 0 p_out = p_out / ab end if end function create_orthogonal @ %def create_orthogonal @ <>= public :: create_unit_vector +<>= + module function create_unit_vector (p_in) result (p_out) + type(vector4_t), intent(in) :: p_in + type(vector3_t) :: p_out + end function create_unit_vector <>= - function create_unit_vector (p_in) result (p_out) + module function create_unit_vector (p_in) result (p_out) type(vector4_t), intent(in) :: p_in type(vector3_t) :: p_out p_out%p = p_in%p(1:3) / space_part_norm (p_in) end function create_unit_vector @ %def create_unit_vector @ <>= public :: normalize +<>= + module function normalize(p) result (p_norm) + type(vector3_t) :: p_norm + type(vector3_t), intent(in) :: p + end function normalize <>= - function normalize(p) result (p_norm) + module function normalize(p) result (p_norm) type(vector3_t) :: p_norm type(vector3_t), intent(in) :: p real(default) :: abs abs = sqrt (p%p(1)**2 + p%p(2)**2 + p%p(3)**2) p_norm = p / abs end function normalize @ %def normalize @ Computes the invariant mass of the momenta sum given by the indices in [[i_res_born]] and the optional argument [[i_emitter]]. <>= public :: compute_resonance_mass +<>= + pure module function compute_resonance_mass (p, i_res_born, i_gluon) result (m) + real(default) :: m + type(vector4_t), intent(in), dimension(:) :: p + integer, intent(in), dimension(:) :: i_res_born + integer, intent(in), optional :: i_gluon + end function compute_resonance_mass <>= - pure function compute_resonance_mass (p, i_res_born, i_gluon) result (m) + pure module function compute_resonance_mass (p, i_res_born, i_gluon) result (m) real(default) :: m type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), dimension(:) :: i_res_born integer, intent(in), optional :: i_gluon type(vector4_t) :: p_res p_res = get_resonance_momentum (p, i_res_born, i_gluon) m = p_res**1 end function compute_resonance_mass @ %def compute_resonance_mass @ <>= public :: get_resonance_momentum +<>= + pure module function get_resonance_momentum & + (p, i_res_born, i_gluon) result (p_res) + type(vector4_t) :: p_res + type(vector4_t), intent(in), dimension(:) :: p + integer, intent(in), dimension(:) :: i_res_born + integer, intent(in), optional :: i_gluon + end function get_resonance_momentum <>= - pure function get_resonance_momentum (p, i_res_born, i_gluon) result (p_res) + pure module function get_resonance_momentum & + (p, i_res_born, i_gluon) result (p_res) type(vector4_t) :: p_res type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), dimension(:) :: i_res_born integer, intent(in), optional :: i_gluon integer :: i p_res = vector4_null do i = 1, size (i_res_born) p_res = p_res + p (i_res_born(i)) end do if (present (i_gluon)) p_res = p_res + p (i_gluon) end function get_resonance_momentum @ %def get_resonance_momentum @ <>= public :: create_two_particle_decay +<>= + module function create_two_particle_decay (s, p1, p2) result (p_rest) + type(vector4_t), dimension(3) :: p_rest + real(default), intent(in) :: s + type(vector4_t), intent(in) :: p1, p2 + end function create_two_particle_decay <>= - function create_two_particle_decay (s, p1, p2) result (p_rest) + module function create_two_particle_decay (s, p1, p2) result (p_rest) type(vector4_t), dimension(3) :: p_rest real(default), intent(in) :: s type(vector4_t), intent(in) :: p1, p2 real(default) :: m1_sq, m2_sq real(default) :: E1, E2, p m1_sq = p1**2; m2_sq = p2**2 p = sqrt (lambda (s, m1_sq, m2_sq)) / (two * sqrt (s)) E1 = sqrt (m1_sq + p**2); E2 = sqrt (m2_sq + p**2) p_rest(1)%p = [sqrt (s), zero, zero, zero] p_rest(2)%p(0) = E1 p_rest(2)%p(1:3) = p * p1%p(1:3) / space_part_norm (p1) p_rest(3)%p(0) = E2; p_rest(3)%p(1:3) = -p_rest(2)%p(1:3) end function create_two_particle_decay @ %def create_two_particle_decay @ This function creates a phase-space point for a $1 \to 3$ decay in the decaying particle's rest frame. There are three rest frames for this system, corresponding to $s$-, $t$,- and $u$-channel momentum exchange, also referred to as Gottfried-Jackson frames. Below, we choose the momentum with index 1 to be aligned along the $z$-axis. We then have \begin{align*} s_1 &= \left(p_1 + p_2\right)^2, \\ s_2 &= \left(p_2 + p_3\right)^2, \\ s_3 &= \left(p_1 + p_3\right)^2, \\ s_1 + s_2 + s_3 &= s + m_1^2 + m_2^2 + m_3^2. \end{align*} From these we can construct \begin{align*} E_1^{R23} = \frac{s - s_2 - m_1^2}{2\sqrt{s_2}} &\quad P_1^{R23} = \frac{\lambda^{1/2}(s, s_2, m_1^2)}{2\sqrt{s_2}},\\ E_2^{R23} = \frac{s_2 + m_2^2 - m_3^2}{2\sqrt{s_2}} &\quad P_2^{R23} = \frac{\lambda^{1/2}(s_2, m_2^2, m_3^2)}{2\sqrt{s_2}},\\ E_3^{R23} = \frac{s_2 + m_3^2 - m_2^2}{2\sqrt{s_2}} &\quad P_3^{R23} = P_2^{R23}, \end{align*} where $R23$ denotes the Gottfried-Jackson frame of our choice. Finally, the scattering angle $\theta_{12}^{R23}$ between momentum $1$ and $2$ can be determined to be \begin{equation*} \cos\theta_{12}^{R23} = \frac{(s - s_2 - m_1^2)(s_2 + m_2^2 - m_3^2) + 2s_2 (m_1^2 + m_2^2 - s_1)} {\lambda^{1/2}(s, s_2, m_1^2) \lambda^{1/2}(s_2, m_2^2, m_3^2)} \end{equation*} <>= public :: create_three_particle_decay +<>= + module function create_three_particle_decay (p1, p2, p3) result (p_rest) + type(vector4_t), dimension(4) :: p_rest + type(vector4_t), intent(in) :: p1, p2, p3 + end function create_three_particle_decay <>= - function create_three_particle_decay (p1, p2, p3) result (p_rest) + module function create_three_particle_decay (p1, p2, p3) result (p_rest) type(vector4_t), dimension(4) :: p_rest type(vector4_t), intent(in) :: p1, p2, p3 real(default) :: E1, E2, E3 real(default) :: pr1, pr2, pr3 real(default) :: s, s1, s2, s3 real(default) :: m1_sq, m2_sq, m3_sq real(default) :: cos_theta_12 type(vector3_t) :: v3_unit type(lorentz_transformation_t) :: rot m1_sq = p1**2 m2_sq = p2**2 m3_sq = p3**2 s1 = (p1 + p2)**2 s2 = (p2 + p3)**2 s3 = (p3 + p1)**2 s = s1 + s2 + s3 - m1_sq - m2_sq - m3_sq E1 = (s - s2 - m1_sq) / (two * sqrt (s2)) E2 = (s2 + m2_sq - m3_sq) / (two * sqrt (s2)) E3 = (s2 + m3_sq - m2_sq) / (two * sqrt (s2)) pr1 = sqrt (lambda (s, s2, m1_sq)) / (two * sqrt (s2)) pr2 = sqrt (lambda (s2, m2_sq, m3_sq)) / (two * sqrt(s2)) pr3 = pr2 cos_theta_12 = ((s - s2 - m1_sq) * (s2 + m2_sq - m3_sq) + two * s2 * (m1_sq + m2_sq - s1)) / & sqrt (lambda (s, s2, m1_sq) * lambda (s2, m2_sq, m3_sq)) v3_unit%p = [zero, zero, one] p_rest(1)%p(0) = E1 p_rest(1)%p(1:3) = v3_unit%p * pr1 p_rest(2)%p(0) = E2 p_rest(2)%p(1:3) = v3_unit%p * pr2 p_rest(3)%p(0) = E3 p_rest(3)%p(1:3) = v3_unit%p * pr3 p_rest(4)%p(0) = (s + s2 - m1_sq) / (2 * sqrt (s2)) p_rest(4)%p(1:3) = - p_rest(1)%p(1:3) rot = rotation (cos_theta_12, sqrt (one - cos_theta_12**2), 2) p_rest(2) = rot * p_rest(2) p_rest(3)%p(1:3) = - p_rest(2)%p(1:3) end function create_three_particle_decay @ %def create_three_particle_decay @ <>= public :: evaluate_one_to_two_splitting_special <>= abstract interface subroutine evaluate_one_to_two_splitting_special (p_origin, & p1_in, p2_in, p1_out, p2_out, msq_in, jac) import type(vector4_t), intent(in) :: p_origin type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(inout) :: p1_out, p2_out real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac end subroutine evaluate_one_to_two_splitting_special end interface @ %def evaluate_one_to_two_splitting_special @ <>= public :: generate_on_shell_decay +<>= + recursive module subroutine generate_on_shell_decay (p_dec, & + p_in, p_out, i_real, msq_in, jac, evaluate_special) + type(vector4_t), intent(in) :: p_dec + type(vector4_t), intent(in), dimension(:) :: p_in + type(vector4_t), intent(inout), dimension(:) :: p_out + integer, intent(in) :: i_real + real(default), intent(in), optional :: msq_in + real(default), intent(inout), optional :: jac + procedure(evaluate_one_to_two_splitting_special), intent(in), & + pointer, optional :: evaluate_special + end subroutine generate_on_shell_decay <>= - recursive subroutine generate_on_shell_decay (p_dec, & + recursive module subroutine generate_on_shell_decay (p_dec, & p_in, p_out, i_real, msq_in, jac, evaluate_special) type(vector4_t), intent(in) :: p_dec type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(inout), dimension(:) :: p_out integer, intent(in) :: i_real real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac procedure(evaluate_one_to_two_splitting_special), intent(in), & pointer, optional :: evaluate_special type(vector4_t) :: p_dec_new integer :: n_recoil n_recoil = size (p_in) - 1 if (n_recoil > 1) then if (present (evaluate_special)) then call evaluate_special (p_dec, p_in(1), sum (p_in (2 : n_recoil + 1)), & p_out(i_real), p_dec_new) call generate_on_shell_decay (p_dec_new, p_in (2 : ), p_out, & i_real + 1, msq_in, jac, evaluate_special) else call evaluate_one_to_two_splitting (p_dec, p_in(1), & sum (p_in (2 : n_recoil + 1)), p_out(i_real), p_dec_new, msq_in, jac) call generate_on_shell_decay (p_dec_new, p_in (2 : ), p_out, & i_real + 1, msq_in, jac) end if else call evaluate_one_to_two_splitting (p_dec, p_in(1), p_in(2), & p_out(i_real), p_out(i_real + 1), msq_in, jac) end if end subroutine generate_on_shell_decay subroutine evaluate_one_to_two_splitting (p_origin, & p1_in, p2_in, p1_out, p2_out, msq_in, jac) type(vector4_t), intent(in) :: p_origin type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(inout) :: p1_out, p2_out real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac type(lorentz_transformation_t) :: L type(vector4_t) :: p1_rest, p2_rest real(default) :: m, msq, msq1, msq2 real(default) :: E1, E2, p real(default) :: lda, rlda_soft call get_rest_frame (p1_in, p2_in, p1_rest, p2_rest) msq = p_origin**2; m = sqrt(msq) msq1 = p1_in**2; msq2 = p2_in**2 lda = lambda (msq, msq1, msq2) if (lda < zero) then print *, 'Encountered lambda < 0 in 1 -> 2 splitting! ' print *, 'lda: ', lda print *, 'm: ', m, 'msq: ', msq print *, 'm1: ', sqrt (msq1), 'msq1: ', msq1 print *, 'm2: ', sqrt (msq2), 'msq2: ', msq2 stop end if p = sqrt (lda) / (two * m) E1 = sqrt (msq1 + p**2) E2 = sqrt (msq2 + p**2) p1_out = shift_momentum (p1_rest, E1, p) p2_out = shift_momentum (p2_rest, E2, p) L = boost (p_origin, p_origin**1) p1_out = L * p1_out p2_out = L * p2_out if (present (jac) .and. present (msq_in)) then jac = jac * sqrt(lda) / msq rlda_soft = sqrt (lambda (msq_in, msq1, msq2)) !!! We have to undo the Jacobian which has already been !!! supplied by the Born phase space. jac = jac * msq_in / rlda_soft end if contains subroutine get_rest_frame (p1_in, p2_in, p1_out, p2_out) type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(out) :: p1_out, p2_out type(lorentz_transformation_t) :: L L = inverse (boost (p1_in + p2_in, (p1_in + p2_in)**1)) p1_out = L * p1_in; p2_out = L * p2_in end subroutine get_rest_frame function shift_momentum (p_in, E, p) result (p_out) type(vector4_t) :: p_out type(vector4_t), intent(in) :: p_in real(default), intent(in) :: E, p type(vector3_t) :: vec - vec = p_in%p(1:3) / space_part_norm (p_in) + vec%p(1:3) = p_in%p(1:3) / space_part_norm (p_in) p_out = vector4_moving (E, p * vec) end function shift_momentum end subroutine evaluate_one_to_two_splitting @ %def generate_on_shell_decay @ \subsection{Boosts} We build Lorentz transformations from boosts and rotations. In both cases we can supply a three-vector which defines the axis and (hyperbolic) angle. For a boost, this is the vector $\vec\beta=\vec p/E$, such that a particle at rest with mass $m$ is boosted to a particle with three-vector $\vec p$. Here, we have \begin{equation} \beta = \tanh\chi = p/E, \qquad \gamma = \cosh\chi = E/m, \qquad \beta\gamma = \sinh\chi = p/m \end{equation} <>= public :: boost <>= interface boost module procedure boost_from_rest_frame module procedure boost_from_rest_frame_vector3 module procedure boost_generic module procedure boost_canonical end interface @ %def boost @ In the first form, the argument is some four-momentum, the space part of which determines a direction, and the associated mass (which is not checked against the four-momentum). The boost vector $\gamma\vec\beta$ is then given by $\vec p/m$. This boosts from the rest frame of a particle to the current frame. To be explicit, if $\vec p$ is the momentum of a particle and $m$ its mass, $L(\vec p/m)$ is the transformation that turns $(m;\vec 0)$ into $(E;\vec p)$. Conversely, the inverse transformation boosts a vector \emph{into} the rest frame of a particle, in particular $(E;\vec p)$ into $(m;\vec 0)$. +<>= + elemental module function boost_from_rest_frame (p, m) result (L) + type(lorentz_transformation_t) :: L + type(vector4_t), intent(in) :: p + real(default), intent(in) :: m + end function boost_from_rest_frame + elemental module function boost_from_rest_frame_vector3 (p, m) result (L) + type(lorentz_transformation_t) :: L + type(vector3_t), intent(in) :: p + real(default), intent(in) :: m + end function boost_from_rest_frame_vector3 <>= - elemental function boost_from_rest_frame (p, m) result (L) + elemental module function boost_from_rest_frame (p, m) result (L) type(lorentz_transformation_t) :: L type(vector4_t), intent(in) :: p real(default), intent(in) :: m L = boost_from_rest_frame_vector3 (space_part (p), m) end function boost_from_rest_frame - elemental function boost_from_rest_frame_vector3 (p, m) result (L) + elemental module function boost_from_rest_frame_vector3 (p, m) result (L) type(lorentz_transformation_t) :: L type(vector3_t), intent(in) :: p real(default), intent(in) :: m type(vector3_t) :: beta_gamma real(default) :: bg2, g, c integer :: i,j if (m > eps0) then beta_gamma = p / m bg2 = beta_gamma**2 else bg2 = 0 L = identity return end if if (bg2 > eps0) then g = sqrt(1 + bg2); c = (g-1)/bg2 else g = one + bg2 / two c = one / two end if L%L(0,0) = g L%L(0,1:) = beta_gamma%p L%L(1:,0) = L%L(0,1:) do i=1,3 do j=1,3 L%L(i,j) = delta_three(i,j) + c*beta_gamma%p(i)*beta_gamma%p(j) end do end do end function boost_from_rest_frame_vector3 @ %def boost_from_rest_frame @ A canonical boost is a boost along one of the coordinate axes, which we may supply as an integer argument. Here, $\gamma\beta$ is scalar. +<>= + elemental module function boost_canonical (beta_gamma, k) result (L) + type(lorentz_transformation_t) :: L + real(default), intent(in) :: beta_gamma + integer, intent(in) :: k + end function boost_canonical <>= - elemental function boost_canonical (beta_gamma, k) result (L) + elemental module function boost_canonical (beta_gamma, k) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: beta_gamma integer, intent(in) :: k real(default) :: g g = sqrt(1 + beta_gamma**2) L = identity L%L(0,0) = g L%L(0,k) = beta_gamma L%L(k,0) = L%L(0,k) L%L(k,k) = L%L(0,0) end function boost_canonical @ %def boost_canonical @ Instead of a canonical axis, we can supply an arbitrary axis which need not be normalized. If it is zero, return the unit matrix. +<>= + elemental module function boost_generic (beta_gamma, axis) result (L) + type(lorentz_transformation_t) :: L + real(default), intent(in) :: beta_gamma + type(vector3_t), intent(in) :: axis + end function boost_generic <>= - elemental function boost_generic (beta_gamma, axis) result (L) + elemental module function boost_generic (beta_gamma, axis) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: beta_gamma type(vector3_t), intent(in) :: axis if (any (abs (axis%p) > 0)) then L = boost_from_rest_frame_vector3 (beta_gamma * axis, axis**1) else L = identity end if end function boost_generic @ %def boost_generic @ \subsection{Rotations} For a rotation, the vector defines the rotation axis, and its length the rotation angle. All of these rotations rotate counterclockwise in a right-handed coordinate system. <>= public :: rotation <>= interface rotation module procedure rotation_generic module procedure rotation_canonical module procedure rotation_generic_cs module procedure rotation_canonical_cs end interface @ %def rotation @ If $\cos\phi$ and $\sin\phi$ is already known, we do not have to calculate them. Of course, the user has to ensure that $\cos^2\phi+\sin^2\phi=1$, and that the given axis [[n]] is normalized to one. In the second form, the length of [[axis]] is the rotation angle. +<>= + elemental module function rotation_generic_cs (cp, sp, axis) result (R) + type(lorentz_transformation_t) :: R + real(default), intent(in) :: cp, sp + type(vector3_t), intent(in) :: axis + end function rotation_generic_cs + elemental module function rotation_generic (axis) result (R) + type(lorentz_transformation_t) :: R + type(vector3_t), intent(in) :: axis + end function rotation_generic + elemental module function rotation_canonical_cs (cp, sp, k) result (R) + type(lorentz_transformation_t) :: R + real(default), intent(in) :: cp, sp + integer, intent(in) :: k + end function rotation_canonical_cs + elemental module function rotation_canonical (phi, k) result (R) + type(lorentz_transformation_t) :: R + real(default), intent(in) :: phi + integer, intent(in) :: k + end function rotation_canonical <>= - elemental function rotation_generic_cs (cp, sp, axis) result (R) + elemental module function rotation_generic_cs (cp, sp, axis) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: cp, sp type(vector3_t), intent(in) :: axis integer :: i,j R = identity do i=1,3 do j=1,3 R%L(i,j) = cp*delta_three(i,j) + (1-cp)*axis%p(i)*axis%p(j) & & - sp*dot_product(epsilon_three(i,j,:), axis%p) end do end do end function rotation_generic_cs - elemental function rotation_generic (axis) result (R) + elemental module function rotation_generic (axis) result (R) type(lorentz_transformation_t) :: R type(vector3_t), intent(in) :: axis real(default) :: phi if (any (abs(axis%p) > 0)) then phi = abs(axis**1) R = rotation_generic_cs (cos(phi), sin(phi), axis/phi) else R = identity end if end function rotation_generic @ %def rotation_generic_cs rotation_generic @ Alternatively, give just the angle and label the coordinate axis by an integer. <>= - elemental function rotation_canonical_cs (cp, sp, k) result (R) + elemental module function rotation_canonical_cs (cp, sp, k) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: cp, sp integer, intent(in) :: k integer :: i,j R = identity do i=1,3 do j=1,3 R%L(i,j) = -sp*epsilon_three(i,j,k) end do R%L(i,i) = cp end do R%L(k,k) = 1 end function rotation_canonical_cs - elemental function rotation_canonical (phi, k) result (R) + elemental module function rotation_canonical (phi, k) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: phi integer, intent(in) :: k R = rotation_canonical_cs(cos(phi), sin(phi), k) end function rotation_canonical @ %def rotation_canonical_cs rotation_canonical @ This is viewed as a method for the first argument (three-vector): Reconstruct the rotation that rotates it into the second three-vector. <>= public :: rotation_to_2nd <>= interface rotation_to_2nd module procedure rotation_to_2nd_generic module procedure rotation_to_2nd_canonical end interface +<>= + elemental module function rotation_to_2nd_generic (p, q) result (R) + type(lorentz_transformation_t) :: R + type(vector3_t), intent(in) :: p, q + end function rotation_to_2nd_generic + elemental module function rotation_to_2nd_canonical (k, p) result (R) + type(lorentz_transformation_t) :: R + integer, intent(in) :: k + type(vector3_t), intent(in) :: p + end function rotation_to_2nd_canonical <>= - elemental function rotation_to_2nd_generic (p, q) result (R) + elemental module function rotation_to_2nd_generic (p, q) result (R) type(lorentz_transformation_t) :: R type(vector3_t), intent(in) :: p, q type(vector3_t) :: a, b, ab real(default) :: ct, st if (any (abs (p%p) > 0) .and. any (abs (q%p) > 0)) then a = direction (p) b = direction (q) ab = cross_product(a,b) ct = a * b; st = ab**1 if (abs(st) > eps0) then R = rotation_generic_cs (ct, st, ab / st) else if (ct < 0) then R = space_reflection else R = identity end if else R = identity end if end function rotation_to_2nd_generic @ %def rotation_to_2nd_generic @ The same for a canonical axis: The function returns the transformation that rotates the $k$-axis into the direction of $p$. <>= - elemental function rotation_to_2nd_canonical (k, p) result (R) + elemental module function rotation_to_2nd_canonical (k, p) result (R) type(lorentz_transformation_t) :: R integer, intent(in) :: k type(vector3_t), intent(in) :: p type(vector3_t) :: b, ab real(default) :: ct, st integer :: i, j if (any (abs (p%p) > 0)) then b = direction (p) ab%p = 0 do i = 1, 3 do j = 1, 3 ab%p(j) = ab%p(j) + b%p(i) * epsilon_three(i,j,k) end do end do ct = b%p(k); st = ab**1 if (abs(st) > eps0) then R = rotation_generic_cs (ct, st, ab / st) else if (ct < 0) then R = space_reflection else R = identity end if else R = identity end if end function rotation_to_2nd_canonical @ %def rotation_to_2nd_canonical @ \subsection{Composite Lorentz transformations} This function returns the transformation that, given a pair of vectors $p_{1,2}$, (a) boosts from the rest frame of the c.m. system (with invariant mass $m$) into the lab frame where $p_i$ are defined, and (b) turns the given axis (or the canonical vectors $\pm e_k$) in the rest frame into the directions of $p_{1,2}$ in the lab frame. Note that the energy components are not used; for a consistent result one should have $(p_1+p_2)^2 = m^2$. <>= public :: transformation <>= interface transformation module procedure transformation_rec_generic module procedure transformation_rec_canonical end interface @ %def transformation +<>= + elemental module function transformation_rec_generic (axis, p1, p2, m) result (L) + type(vector3_t), intent(in) :: axis + type(vector4_t), intent(in) :: p1, p2 + real(default), intent(in) :: m + type(lorentz_transformation_t) :: L + end function transformation_rec_generic + elemental module function transformation_rec_canonical (k, p1, p2, m) result (L) + integer, intent(in) :: k + type(vector4_t), intent(in) :: p1, p2 + real(default), intent(in) :: m + type(lorentz_transformation_t) :: L + end function transformation_rec_canonical <>= - elemental function transformation_rec_generic (axis, p1, p2, m) result (L) + elemental module function transformation_rec_generic (axis, p1, p2, m) result (L) type(vector3_t), intent(in) :: axis type(vector4_t), intent(in) :: p1, p2 real(default), intent(in) :: m type(lorentz_transformation_t) :: L L = boost (p1 + p2, m) L = L * rotation_to_2nd (axis, space_part (inverse (L) * p1)) end function transformation_rec_generic - elemental function transformation_rec_canonical (k, p1, p2, m) result (L) + elemental module function transformation_rec_canonical (k, p1, p2, m) result (L) integer, intent(in) :: k type(vector4_t), intent(in) :: p1, p2 real(default), intent(in) :: m type(lorentz_transformation_t) :: L L = boost (p1 + p2, m) L = L * rotation_to_2nd (k, space_part (inverse (L) * p1)) end function transformation_rec_canonical @ %def transformation_rec_generic transformation_rec_canonical @ \subsection{Applying Lorentz transformations} Multiplying vectors and Lorentz transformations is straightforward. <>= interface operator(*) module procedure prod_LT_vector4 module procedure prod_LT_LT module procedure prod_vector4_LT end interface +<>= + elemental module function prod_LT_vector4 (L, p) result (np) + type(vector4_t) :: np + type(lorentz_transformation_t), intent(in) :: L + type(vector4_t), intent(in) :: p + end function prod_LT_vector4 + elemental module function prod_LT_LT (L1, L2) result (NL) + type(lorentz_transformation_t) :: NL + type(lorentz_transformation_t), intent(in) :: L1,L2 + end function prod_LT_LT + elemental module function prod_vector4_LT (p, L) result (np) + type(vector4_t) :: np + type(vector4_t), intent(in) :: p + type(lorentz_transformation_t), intent(in) :: L + end function prod_vector4_LT <>= - elemental function prod_LT_vector4 (L, p) result (np) + elemental module function prod_LT_vector4 (L, p) result (np) type(vector4_t) :: np type(lorentz_transformation_t), intent(in) :: L type(vector4_t), intent(in) :: p np%p = matmul (L%L, p%p) end function prod_LT_vector4 - elemental function prod_LT_LT (L1, L2) result (NL) + elemental module function prod_LT_LT (L1, L2) result (NL) type(lorentz_transformation_t) :: NL type(lorentz_transformation_t), intent(in) :: L1,L2 NL%L = matmul (L1%L, L2%L) end function prod_LT_LT - elemental function prod_vector4_LT (p, L) result (np) + elemental module function prod_vector4_LT (p, L) result (np) type(vector4_t) :: np type(vector4_t), intent(in) :: p type(lorentz_transformation_t), intent(in) :: L np%p = matmul (p%p, L%L) end function prod_vector4_LT @ %def * @ \subsection{Special Lorentz transformations} These routines have their application in the generation and extraction of angles in the phase-space sampling routine. Since this part of the program is time-critical, we calculate the composition of transformations directly instead of multiplying rotations and boosts. This Lorentz transformation is the composition of a rotation by $\phi$ around the $3$ axis, a rotation by $\theta$ around the $2$ axis, and a boost along the $3$ axis: \begin{equation} L = B_3(\beta\gamma)\,R_2(\theta)\,R_3(\phi) \end{equation} Instead of the angles we provide sine and cosine. <>= public :: LT_compose_r3_r2_b3 +<>= + elemental module function LT_compose_r3_r2_b3 & + (cp, sp, ct, st, beta_gamma) result (L) + type(lorentz_transformation_t) :: L + real(default), intent(in) :: cp, sp, ct, st, beta_gamma + end function LT_compose_r3_r2_b3 <>= - elemental function LT_compose_r3_r2_b3 & + elemental module function LT_compose_r3_r2_b3 & (cp, sp, ct, st, beta_gamma) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: cp, sp, ct, st, beta_gamma real(default) :: gamma if (abs(beta_gamma) < eps0) then L%L(0,0) = 1 L%L(1:,0) = 0 L%L(0,1:) = 0 L%L(1,1:) = [ ct*cp, -ct*sp, st ] L%L(2,1:) = [ sp, cp, zero ] L%L(3,1:) = [ -st*cp, st*sp, ct ] else gamma = sqrt(1 + beta_gamma**2) L%L(0,0) = gamma L%L(1,0) = 0 L%L(2,0) = 0 L%L(3,0) = beta_gamma L%L(0,1:) = beta_gamma * [ -st*cp, st*sp, ct ] L%L(1,1:) = [ ct*cp, -ct*sp, st ] L%L(2,1:) = [ sp, cp, zero ] L%L(3,1:) = gamma * [ -st*cp, st*sp, ct ] end if end function LT_compose_r3_r2_b3 @ %def LT_compose_r3_r2_b3 @ Different ordering: \begin{equation} L = B_3(\beta\gamma)\,R_3(\phi)\,R_2(\theta) \end{equation} <>= public :: LT_compose_r2_r3_b3 +<>= + elemental module function LT_compose_r2_r3_b3 & + (ct, st, cp, sp, beta_gamma) result (L) + type(lorentz_transformation_t) :: L + real(default), intent(in) :: ct, st, cp, sp, beta_gamma + end function LT_compose_r2_r3_b3 <>= - elemental function LT_compose_r2_r3_b3 & + elemental module function LT_compose_r2_r3_b3 & (ct, st, cp, sp, beta_gamma) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: ct, st, cp, sp, beta_gamma real(default) :: gamma if (abs(beta_gamma) < eps0) then L%L(0,0) = 1 L%L(1:,0) = 0 L%L(0,1:) = 0 L%L(1,1:) = [ ct*cp, -sp, st*cp ] L%L(2,1:) = [ ct*sp, cp, st*sp ] L%L(3,1:) = [ -st , zero, ct ] else gamma = sqrt(1 + beta_gamma**2) L%L(0,0) = gamma L%L(1,0) = 0 L%L(2,0) = 0 L%L(3,0) = beta_gamma L%L(0,1:) = beta_gamma * [ -st , zero, ct ] L%L(1,1:) = [ ct*cp, -sp, st*cp ] L%L(2,1:) = [ ct*sp, cp, st*sp ] L%L(3,1:) = gamma * [ -st , zero, ct ] end if end function LT_compose_r2_r3_b3 @ %def LT_compose_r2_r3_b3 @ This function returns the previous Lorentz transformation applied to an arbitrary four-momentum and extracts the space part of the result: \begin{equation} \vec n = [B_3(\beta\gamma)\,R_2(\theta)\,R_3(\phi)\,p]_{\rm space\ part} \end{equation} The second variant applies if there is no rotation <>= public :: axis_from_p_r3_r2_b3, axis_from_p_b3 +<>= + elemental module function axis_from_p_r3_r2_b3 & + (p, cp, sp, ct, st, beta_gamma) result (n) + type(vector3_t) :: n + type(vector4_t), intent(in) :: p + real(default), intent(in) :: cp, sp, ct, st, beta_gamma + end function axis_from_p_r3_r2_b3 + elemental module function axis_from_p_b3 (p, beta_gamma) result (n) + type(vector3_t) :: n + type(vector4_t), intent(in) :: p + real(default), intent(in) :: beta_gamma + end function axis_from_p_b3 <>= - elemental function axis_from_p_r3_r2_b3 & + elemental module function axis_from_p_r3_r2_b3 & (p, cp, sp, ct, st, beta_gamma) result (n) type(vector3_t) :: n type(vector4_t), intent(in) :: p real(default), intent(in) :: cp, sp, ct, st, beta_gamma real(default) :: gamma, px, py px = cp * p%p(1) - sp * p%p(2) py = sp * p%p(1) + cp * p%p(2) n%p(1) = ct * px + st * p%p(3) n%p(2) = py n%p(3) = -st * px + ct * p%p(3) if (abs(beta_gamma) > eps0) then gamma = sqrt(1 + beta_gamma**2) n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma end if end function axis_from_p_r3_r2_b3 - elemental function axis_from_p_b3 (p, beta_gamma) result (n) + elemental module function axis_from_p_b3 (p, beta_gamma) result (n) type(vector3_t) :: n type(vector4_t), intent(in) :: p real(default), intent(in) :: beta_gamma real(default) :: gamma n%p = p%p(1:3) if (abs(beta_gamma) > eps0) then gamma = sqrt(1 + beta_gamma**2) n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma end if end function axis_from_p_b3 @ %def axis_from_p_r3_r2_b3 axis_from_p_b3 @ \subsection{Special functions} The K\"all\'en function, mostly used for the phase space. This is equivalent to $\lambda(x,y,z)=x^2+y^2+z^2-2xy-2xz-2yz$. <>= public :: lambda +<>= + elemental module function lambda (m1sq, m2sq, m3sq) + real(default) :: lambda + real(default), intent(in) :: m1sq, m2sq, m3sq + end function lambda <>= - elemental function lambda (m1sq, m2sq, m3sq) + elemental module function lambda (m1sq, m2sq, m3sq) real(default) :: lambda real(default), intent(in) :: m1sq, m2sq, m3sq lambda = (m1sq - m2sq - m3sq)**2 - 4*m2sq*m3sq end function lambda @ %def lambda @ Return a pair of head-to-head colliding momenta, given the collider energy, particle masses, and optionally the momentum of the c.m. system. <>= public :: colliding_momenta +<>= + module function colliding_momenta (sqrts, m, p_cm) result (p) + type(vector4_t), dimension(2) :: p + real(default), intent(in) :: sqrts + real(default), dimension(2), intent(in), optional :: m + real(default), intent(in), optional :: p_cm + end function colliding_momenta <>= - function colliding_momenta (sqrts, m, p_cm) result (p) + module function colliding_momenta (sqrts, m, p_cm) result (p) type(vector4_t), dimension(2) :: p real(default), intent(in) :: sqrts real(default), dimension(2), intent(in), optional :: m real(default), intent(in), optional :: p_cm real(default), dimension(2) :: dmsq real(default) :: ch, sh real(default), dimension(2) :: E0, p0 integer, dimension(2), parameter :: sgn = [1, -1] if (abs(sqrts) < eps0) then call msg_fatal (" Colliding beams: sqrts is zero (please set sqrts)") p = vector4_null; return else if (sqrts <= 0) then call msg_fatal (" Colliding beams: sqrts is negative") p = vector4_null; return end if if (present (m)) then dmsq = sgn * (m(1)**2-m(2)**2) E0 = (sqrts + dmsq/sqrts) / 2 if (any (E0 < m)) then call msg_fatal & (" Colliding beams: beam energy is less than particle mass") p = vector4_null; return end if p0 = sgn * sqrt (E0**2 - m**2) else E0 = sqrts / 2 p0 = sgn * E0 end if if (present (p_cm)) then sh = p_cm / sqrts ch = sqrt (1 + sh**2) p = vector4_moving (E0 * ch + p0 * sh, E0 * sh + p0 * ch, 3) else p = vector4_moving (E0, p0, 3) end if end function colliding_momenta @ %def colliding_momenta @ This subroutine is for the purpose of numerical checks and comparisons. The idea is to set a number to zero if it is numerically equivalent with zero. The equivalence is established by comparing with a [[tolerance]] argument. We implement this for vectors and transformations. <>= public :: pacify <>= interface pacify module procedure pacify_vector3 module procedure pacify_vector4 module procedure pacify_LT end interface pacify +<>= + elemental module subroutine pacify_vector3 (p, tolerance) + type(vector3_t), intent(inout) :: p + real(default), intent(in) :: tolerance + end subroutine pacify_vector3 + elemental module subroutine pacify_vector4 (p, tolerance) + type(vector4_t), intent(inout) :: p + real(default), intent(in) :: tolerance + end subroutine pacify_vector4 + elemental module subroutine pacify_LT (LT, tolerance) + type(lorentz_transformation_t), intent(inout) :: LT + real(default), intent(in) :: tolerance + end subroutine pacify_LT <>= - elemental subroutine pacify_vector3 (p, tolerance) + elemental module subroutine pacify_vector3 (p, tolerance) type(vector3_t), intent(inout) :: p real(default), intent(in) :: tolerance where (abs (p%p) < tolerance) p%p = zero end subroutine pacify_vector3 - elemental subroutine pacify_vector4 (p, tolerance) + elemental module subroutine pacify_vector4 (p, tolerance) type(vector4_t), intent(inout) :: p real(default), intent(in) :: tolerance where (abs (p%p) < tolerance) p%p = zero end subroutine pacify_vector4 - elemental subroutine pacify_LT (LT, tolerance) + elemental module subroutine pacify_LT (LT, tolerance) type(lorentz_transformation_t), intent(inout) :: LT real(default), intent(in) :: tolerance where (abs (LT%L) < tolerance) LT%L = zero end subroutine pacify_LT @ %def pacify @ <>= public :: vector_set_reshuffle +<>= + module subroutine vector_set_reshuffle (p1, list, p2) + type(vector4_t), intent(in), dimension(:), allocatable :: p1 + integer, intent(in), dimension(:), allocatable :: list + type(vector4_t), intent(out), dimension(:), allocatable :: p2 + end subroutine vector_set_reshuffle <>= - subroutine vector_set_reshuffle (p1, list, p2) + module subroutine vector_set_reshuffle (p1, list, p2) type(vector4_t), intent(in), dimension(:), allocatable :: p1 integer, intent(in), dimension(:), allocatable :: list type(vector4_t), intent(out), dimension(:), allocatable :: p2 integer :: n, n_p n_p = size (p1) if (size (list) /= n_p) return allocate (p2 (n_p)) do n = 1, n_p p2(n) = p1(list(n)) end do end subroutine vector_set_reshuffle @ %def vector_set_reshuffle @ <>= public :: vector_set_is_cms +<>= + module function vector_set_is_cms (p, n_in) result (is_cms) + logical :: is_cms + type(vector4_t), intent(in), dimension(:) :: p + integer, intent(in) :: n_in + end function vector_set_is_cms <>= - function vector_set_is_cms (p, n_in) result (is_cms) + module function vector_set_is_cms (p, n_in) result (is_cms) logical :: is_cms type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: n_in integer :: i type(vector4_t) :: p_sum p_sum%p = 0._default do i = 1, n_in p_sum = p_sum + p(i) end do is_cms = all (abs (p_sum%p(1:3)) < tiny_07) end function vector_set_is_cms @ %def vector_set_is_cms @ <>= public :: vector_set_is_lab +<>= + module function vector_set_is_lab (p, n_in) result (is_lab) + logical :: is_lab + type(vector4_t), intent(in), dimension(:) :: p + integer, intent(in) :: n_in + end function vector_set_is_lab <>= - function vector_set_is_lab (p, n_in) result (is_lab) + module function vector_set_is_lab (p, n_in) result (is_lab) logical :: is_lab type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: n_in is_lab = .not. vector_set_is_cms (p, n_in) end function vector_set_is_lab @ %def vector_set_is_lab @ <>= public :: vector4_write_set +<>= + module subroutine vector4_write_set (p, unit, show_mass, testflag, & + check_conservation, ultra, n_in) + type(vector4_t), intent(in), dimension(:) :: p + integer, intent(in), optional :: unit + logical, intent(in), optional :: show_mass + logical, intent(in), optional :: testflag, ultra + logical, intent(in), optional :: check_conservation + integer, intent(in), optional :: n_in + end subroutine vector4_write_set <>= - subroutine vector4_write_set (p, unit, show_mass, testflag, & + module subroutine vector4_write_set (p, unit, show_mass, testflag, & check_conservation, ultra, n_in) type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass logical, intent(in), optional :: testflag, ultra logical, intent(in), optional :: check_conservation integer, intent(in), optional :: n_in logical :: extreme integer :: i, j real(default), dimension(0:3) :: p_tot character(len=7) :: fmt integer :: u logical :: yorn, is_test integer :: n extreme = .false.; if (present (ultra)) extreme = ultra is_test = .false.; if (present (testflag)) is_test = testflag u = given_output_unit (unit); if (u < 0) return n = 2; if (present (n_in)) n = n_in p_tot = 0 yorn = .false.; if (present (check_conservation)) yorn = check_conservation do i = 1, size (p) if (yorn .and. i > n) then forall (j=0:3) p_tot(j) = p_tot(j) - p(i)%p(j) else forall (j=0:3) p_tot(j) = p_tot(j) + p(i)%p(j) end if call vector4_write (p(i), u, show_mass=show_mass, & testflag=testflag, ultra=ultra) end do if (extreme) then call pac_fmt (fmt, FMT_19, FMT_11, testflag) else call pac_fmt (fmt, FMT_19, FMT_15, testflag) end if if (is_test) call pacify (p_tot, 1.E-9_default) if (.not. is_test) then write (u, "(A5)") 'Total: ' write (u, "(1x,A,1x," // fmt // ")") "E = ", p_tot(0) write (u, "(1x,A,3(1x," // fmt // "))") "P = ", p_tot(1:) end if end subroutine vector4_write_set @ %def vector4_write_set @ <>= public :: vector4_check_momentum_conservation +<>= + module subroutine vector4_check_momentum_conservation (p, n_in, unit, & + abs_smallness, rel_smallness, verbose) + type(vector4_t), dimension(:), intent(in) :: p + integer, intent(in) :: n_in + integer, intent(in), optional :: unit + real(default), intent(in), optional :: abs_smallness, rel_smallness + logical, intent(in), optional :: verbose + end subroutine vector4_check_momentum_conservation <>= - subroutine vector4_check_momentum_conservation (p, n_in, unit, & + module subroutine vector4_check_momentum_conservation (p, n_in, unit, & abs_smallness, rel_smallness, verbose) type(vector4_t), dimension(:), intent(in) :: p integer, intent(in) :: n_in integer, intent(in), optional :: unit real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: verbose integer :: u, i type(vector4_t) :: psum_in, psum_out logical, dimension(0:3) :: p_diff logical :: verb u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose psum_in = vector4_null do i = 1, n_in psum_in = psum_in + p(i) end do psum_out = vector4_null do i = n_in + 1, size (p) psum_out = psum_out + p(i) end do p_diff = vanishes (psum_in%p - psum_out%p, & abs_smallness = abs_smallness, rel_smallness = rel_smallness) if (.not. all (p_diff)) then call msg_warning ("Momentum conservation: FAIL", unit = u) if (verb) then write (u, "(A)") "Incoming:" call vector4_write (psum_in, u) write (u, "(A)") "Outgoing:" call vector4_write (psum_out, u) end if else if (verb) then write (u, "(A)") "Momentum conservation: CHECK" end if end if end subroutine vector4_check_momentum_conservation @ %def vector4_check_momentum_conservation @ This computes the quantities \begin{align*} \langle ij \rangle &= \sqrt{|S_{ij}|} e^{i\phi_{ij}}, [ij] &= \sqrt{|S_{ij}|} e^{\i\tilde{\phi}_{ij}}, \end{align*} with $S_{ij} = \left(p_i + p_j\right)^2$. The phase space factor $\phi_{ij}$ is determined by \begin{align*} \cos\phi_{ij} &= \frac{p_i^1p_j^+ - p_j^1p_i^+}{\sqrt{p_i^+p_j^+S_{ij}}}, \sin\phi_{ij} &= \frac{p_i^2p_j^+ - p_j^2p_i^+}{\sqrt{p_i^+p_j^+S_{ij}}}. \end{align*} After $\langle ij \rangle$ has been computed according to these formulae, $[ij]$ can be obtained by using the relation $S_{ij} = \langle ij \rangle [ji]$ and taking into account that $[ij] = -[ji]$. Thus, a minus-sign has to be applied. <>= public :: spinor_product +<>= + module subroutine spinor_product (p1, p2, prod1, prod2) + type(vector4_t), intent(in) :: p1, p2 + complex(default), intent(out) :: prod1, prod2 + end subroutine spinor_product <>= - subroutine spinor_product (p1, p2, prod1, prod2) + module subroutine spinor_product (p1, p2, prod1, prod2) type(vector4_t), intent(in) :: p1, p2 complex(default), intent(out) :: prod1, prod2 real(default) :: sij complex(default) :: phase real(default) :: pp_1, pp_2 pp_1 = p1%p(0) + p1%p(3) pp_2 = p2%p(0) + p2%p(3) sij = (p1+p2)**2 phase = cmplx ((p1%p(1)*pp_2 - p2%p(1)*pp_1)/sqrt (sij*pp_1*pp_2), & (p1%p(2)*pp_2 - p2%p(2)*pp_1)/sqrt (sij*pp_1*pp_2), & default) !!! prod1 = sqrt (sij) * phase !!! [ij] if (abs(prod1) > 0) then prod2 = - sij / prod1 else prod2 = 0 end if end subroutine spinor_product @ %def spinor_product %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Collections of Lorentz Vectors} The [[phs_point]] type is a container for an array of Lorentz vectors. This allows us to transfer Lorentz-vector arrays more freely, and to collect vector arrays of non-uniform size. <<[[phs_points.f90]]>>= <> module phs_points <> use lorentz, only: vector4_t - use lorentz, only: vector4_null - use lorentz, only: vector4_write_set use lorentz, only: lorentz_transformation_t - use lorentz, only: operator(==) - use lorentz, only: operator(*) - use lorentz, only: operator(**) use lorentz, only: sum <> <> <> <> + interface +<> + end interface + +end module phs_points +@ %def phs_points +@ +<<[[phs_points_sub.f90]]>>= +<> + +submodule (phs_points) phs_points_s + + use lorentz, only: vector4_null + use lorentz, only: vector4_write_set + use lorentz, only: operator(==) + use lorentz, only: operator(*) + use lorentz, only: operator(**) + + implicit none + contains <> -end module phs_points -@ %def phs_points +end submodule phs_points_s + +@ %def phs_points_s @ \subsection{PHS point definition} This is a trivial container for an array of momenta. The main application is to store a non-uniform array of phase-space points. <>= public :: phs_point_t <>= type :: phs_point_t private type(vector4_t), dimension(:), allocatable :: p contains <> end type phs_point_t @ %def phs_point_t @ \subsection{PHS point: basic tools} Output. This is instrumented with options, which have to be provided by the caller. <>= procedure :: write => phs_point_write +<>= + module subroutine phs_point_write (phs_point, unit, show_mass, testflag, & + check_conservation, ultra, n_in) + class(phs_point_t), intent(in) :: phs_point + integer, intent(in), optional :: unit + logical, intent(in), optional :: show_mass + logical, intent(in), optional :: testflag, ultra + logical, intent(in), optional :: check_conservation + integer, intent(in), optional :: n_in + end subroutine phs_point_write <>= - subroutine phs_point_write (phs_point, unit, show_mass, testflag, & + module subroutine phs_point_write (phs_point, unit, show_mass, testflag, & check_conservation, ultra, n_in) class(phs_point_t), intent(in) :: phs_point integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass logical, intent(in), optional :: testflag, ultra logical, intent(in), optional :: check_conservation integer, intent(in), optional :: n_in if (allocated (phs_point%p)) then call vector4_write_set (phs_point%p, & unit = unit, & show_mass = show_mass, & testflag = testflag, & check_conservation = check_conservation, & ultra = ultra, & n_in = n_in) end if end subroutine phs_point_write @ %def phs_point_write @ Non-intrinsic assignment <>= public :: assignment(=) <>= interface assignment(=) module procedure phs_point_from_n module procedure phs_point_from_vector4 module procedure vector4_from_phs_point end interface @ Initialize with zero momenta but fixed size +<>= + pure module subroutine phs_point_from_n (phs_point, n_particles) + type(phs_point_t), intent(out) :: phs_point + integer, intent(in) :: n_particles + end subroutine phs_point_from_n <>= - pure subroutine phs_point_from_n (phs_point, n_particles) + pure module subroutine phs_point_from_n (phs_point, n_particles) type(phs_point_t), intent(out) :: phs_point integer, intent(in) :: n_particles allocate (phs_point%p (n_particles), source = vector4_null) end subroutine phs_point_from_n @ %def phs_point_init_from_n @ Transform from/to plain vector array +<>= + pure module subroutine phs_point_from_vector4 (phs_point, p) + type(phs_point_t), intent(out) :: phs_point + type(vector4_t), dimension(:), intent(in) :: p + end subroutine phs_point_from_vector4 + pure module subroutine vector4_from_phs_point (p, phs_point) + class(phs_point_t), intent(in) :: phs_point + type(vector4_t), dimension(:), allocatable, intent(out) :: p + end subroutine vector4_from_phs_point <>= - pure subroutine phs_point_from_vector4 (phs_point, p) + pure module subroutine phs_point_from_vector4 (phs_point, p) type(phs_point_t), intent(out) :: phs_point type(vector4_t), dimension(:), intent(in) :: p phs_point%p = p end subroutine phs_point_from_vector4 - pure subroutine vector4_from_phs_point (p, phs_point) + pure module subroutine vector4_from_phs_point (p, phs_point) class(phs_point_t), intent(in) :: phs_point type(vector4_t), dimension(:), allocatable, intent(out) :: p if (allocated (phs_point%p)) p = phs_point%p end subroutine vector4_from_phs_point @ %def phs_point_from_vector4 @ %def vector4_from_phs_point @ Query the size of the momentum array (assuming it is allocated). <>= public :: size <>= interface size module procedure phs_point_size end interface size +<>= + pure module function phs_point_size (phs_point) result (s) + class(phs_point_t), intent(in) :: phs_point + integer :: s + end function phs_point_size <>= - pure function phs_point_size (phs_point) result (s) + pure module function phs_point_size (phs_point) result (s) class(phs_point_t), intent(in) :: phs_point integer :: s if (allocated (phs_point%p)) then s = size (phs_point%p) else s = 0 end if end function phs_point_size @ %def phs_point_size @ Equality, implemented only for valid points. <>= public :: operator(==) <>= interface operator(==) module procedure phs_point_eq end interface operator(==) +<>= + elemental module function phs_point_eq & + (phs_point_1, phs_point_2) result (flag) + class(phs_point_t), intent(in) :: phs_point_1, phs_point_2 + logical :: flag + end function phs_point_eq <>= - elemental function phs_point_eq (phs_point_1, phs_point_2) result (flag) + elemental module function phs_point_eq & + (phs_point_1, phs_point_2) result (flag) class(phs_point_t), intent(in) :: phs_point_1, phs_point_2 logical :: flag if (allocated (phs_point_1%p) .and. (allocated (phs_point_2%p))) then flag = all (phs_point_1%p == phs_point_2%p) else flag = .false. end if end function phs_point_eq @ %def phs_point_eq @ Extract all momenta, as a method <>= procedure :: get => phs_point_get +<>= + pure module function phs_point_get (phs_point) result (p) + class(phs_point_t), intent(in) :: phs_point + type(vector4_t), dimension(:), allocatable :: p + end function phs_point_get <>= - pure function phs_point_get (phs_point) result (p) + pure module function phs_point_get (phs_point) result (p) class(phs_point_t), intent(in) :: phs_point type(vector4_t), dimension(:), allocatable :: p if (allocated (phs_point%p)) then p = phs_point%p else allocate (p (0)) end if end function phs_point_get @ %def phs_point_select @ Extract a subset of all momenta. <>= procedure :: select => phs_point_select +<>= + elemental module function phs_point_select (phs_point, i) result (p) + class(phs_point_t), intent(in) :: phs_point + integer, intent(in) :: i + type(vector4_t) :: p + end function phs_point_select <>= - elemental function phs_point_select (phs_point, i) result (p) + elemental module function phs_point_select (phs_point, i) result (p) class(phs_point_t), intent(in) :: phs_point integer, intent(in) :: i type(vector4_t) :: p if (allocated (phs_point%p)) then p = phs_point%p(i) else p = vector4_null end if end function phs_point_select @ %def phs_point_select @ Return the invariant mass squared for a subset of momenta <>= procedure :: get_msq => phs_point_get_msq +<>= + pure module function phs_point_get_msq (phs_point, iarray) result (msq) + class(phs_point_t), intent(in) :: phs_point + integer, dimension(:), intent(in) :: iarray + real(default) :: msq + end function phs_point_get_msq <>= - pure function phs_point_get_msq (phs_point, iarray) result (msq) + pure module function phs_point_get_msq (phs_point, iarray) result (msq) class(phs_point_t), intent(in) :: phs_point integer, dimension(:), intent(in) :: iarray real(default) :: msq if (allocated (phs_point%p)) then msq = (sum (phs_point%p(iarray)))**2 else msq = 0 end if end function phs_point_get_msq @ %def phs_point_get_msq @ \subsection{Lorentz algebra pieces} Lorentz transformation. <>= public :: operator(*) <>= interface operator(*) module procedure prod_LT_phs_point end interface operator(*) +<>= + elemental module function prod_LT_phs_point (L, phs_point) result (phs_point_LT) + type(lorentz_transformation_t), intent(in) :: L + type(phs_point_t), intent(in) :: phs_point + type(phs_point_t) :: phs_point_LT + end function prod_LT_phs_point <>= - elemental function prod_LT_phs_point (L, phs_point) result (phs_point_LT) + elemental module function prod_LT_phs_point (L, phs_point) result (phs_point_LT) type(lorentz_transformation_t), intent(in) :: L type(phs_point_t), intent(in) :: phs_point type(phs_point_t) :: phs_point_LT if (allocated (phs_point%p)) phs_point_LT%p = L * phs_point%p end function prod_LT_phs_point @ %def prod_LT_phs_point @ Compute momentum sum, analogous to the standard [[sum]] function (mask), and additionally using an index array. <>= public :: sum <>= interface sum module procedure phs_point_sum module procedure phs_point_sum_iarray end interface sum +<>= + pure module function phs_point_sum (phs_point, mask) result (p) + class(phs_point_t), intent(in) :: phs_point + logical, dimension(:), intent(in), optional :: mask + type(vector4_t) :: p + end function phs_point_sum + pure module function phs_point_sum_iarray (phs_point, iarray) result (p) + class(phs_point_t), intent(in) :: phs_point + integer, dimension(:), intent(in) :: iarray + type(vector4_t) :: p + end function phs_point_sum_iarray <>= - pure function phs_point_sum (phs_point, mask) result (p) + pure module function phs_point_sum (phs_point, mask) result (p) class(phs_point_t), intent(in) :: phs_point logical, dimension(:), intent(in), optional :: mask type(vector4_t) :: p if (allocated (phs_point%p)) then p = sum (phs_point%p, mask) else p = vector4_null end if end function phs_point_sum - pure function phs_point_sum_iarray (phs_point, iarray) result (p) + pure module function phs_point_sum_iarray (phs_point, iarray) result (p) class(phs_point_t), intent(in) :: phs_point integer, dimension(:), intent(in) :: iarray type(vector4_t) :: p logical, dimension(:), allocatable :: mask integer :: i allocate (mask (size (phs_point)), source = .false.) mask(iarray) = .true. p = sum (phs_point, mask) end function phs_point_sum_iarray @ %def phs_point_sum @ \subsection{Methods for specific applications} Convenience method: compute the pair of energy fractions w.r.t.\ the specified beam energy. We assume that the momenta represent a scattering process (two incoming particles) in the c.m.\ frame. <>= procedure :: get_x => phs_point_get_x +<>= + pure module function phs_point_get_x (phs_point, E_beam) result (x) + class(phs_point_t), intent(in) :: phs_point + real(default), dimension(2) :: x + real(default), intent(in) :: E_beam + end function phs_point_get_x <>= - pure function phs_point_get_x (phs_point, E_beam) result (x) + pure module function phs_point_get_x (phs_point, E_beam) result (x) class(phs_point_t), intent(in) :: phs_point real(default), dimension(2) :: x real(default), intent(in) :: E_beam x = phs_point%p(1:2)%p(0) / E_beam end function phs_point_get_x @ %def phs_point_get_x @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_points_ut.f90]]>>= <> module phs_points_ut use unit_tests use phs_points_uti <> <> contains <> end module phs_points_ut @ %def phs_points_ut @ <<[[phs_points_uti.f90]]>>= <> module phs_points_uti <> use phs_points <> <> contains <> end module phs_points_uti @ %def phs_points_ut @ API: driver for the unit tests below. <>= public :: phs_points_test <>= subroutine phs_points_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_points_test @ %def phs_points_test @ \subsubsection{Splitting functions} <>= call test (phs_points_1, "phs_points_1", & "Dummy test", & u, results) <>= public :: phs_points_1 <>= subroutine phs_points_1 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: phs_points_1" write (u, "(A)") "* Purpose: none yet" write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Test output end: phs_points_1" end subroutine phs_points_1 @ %def phs_points_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Special Physics functions} Here, we declare functions that are specific for the Standard Model, including QCD: fixed and running $\alpha_s$, Catani-Seymour dipole terms, loop functions, etc. To make maximum use of this, all functions, if possible, are declared elemental (or pure, if this is not possible). <<[[sm_physics.f90]]>>= <> module sm_physics -<> - use io_units +<> use constants - use numeric_utils - use diagnostics - use permutations, only: factorial use physics_defs use lorentz <> <> <> + interface +<> + end interface + +end module sm_physics +@ %def sm_physics +@ +<<[[sm_physics_sub.f90]]>>= +<> + +submodule (sm_physics) sm_physics_s + + use io_units + use numeric_utils + use diagnostics + use permutations, only: factorial + + implicit none + contains <> -end module sm_physics -@ %def sm_physics +end submodule sm_physics_s + +@ %def sm_physics_s @ \subsection{Constants for Quantum Field Theory calculations} For loop calculations in quantum field theories, one needs the numerical values of the Riemann zeta function: \begin{align*} \zeta(2) &=\; 1.64493406684822643647241516665\ldots \; \\ \zeta(3) &=\; 1.20205690315959428539973816151\ldots \; \\ \zeta(4) &=\; 1.08232323371113819151600369654\ldots \; \\ \zeta(5) &=\; 1.03692775514336992633136548646\ldots \; \end{align*} <>= public :: zeta2, zeta3, zeta4, zeta5 <>= real(default), parameter :: & zeta2 = 1.64493406684822643647241516665_default, & zeta3 = 1.20205690315959428539973816151_default, & zeta4 = 1.08232323371113819151600369654_default, & zeta5 = 1.03692775514336992633136548646_default @ %def zeta2 zeta3 zeta4 @ The Euler-Mascheroni constant is \begin{equation*} \gamma_E = \end{equation*} <>= public :: eulerc <>= real(default), parameter :: & eulerc =0.5772156649015328606065120900824024310422_default @ %def eulerc @ \subsection{Running $\alpha_s$} Then we define the coefficients of the beta function of QCD (as a reference cf. the Particle Data Group), where $n_f$ is the number of active flavors in two different schemes: \begin{align} \beta_0 &=\; 11 - \frac23 n_f \\ \beta_1 &=\; 51 - \frac{19}{3} n_f \\ \beta_2 &=\; 2857 - \frac{5033}{9} n_f + \frac{325}{27} n_f^2 \end{align} \begin{align} b_0 &=\; \frac{1}{12 \pi} \left( 11 C_A - 2 n_f \right) \\ b_1 &=\; \frac{1}{24 \pi^2} \left( 17 C_A^2 - 5 C_A n_f - 3 C_F n_f \right) \\ b_2 &=\; \frac{1}{(4\pi)^3} \biggl( \frac{2857}{54} C_A^3 - \frac{1415}{54} * C_A^2 n_f - \frac{205}{18} C_A C_F n_f + C_F^2 n_f + \frac{79}{54} C_A n_f**2 + \frac{11}{9} C_F n_f**2 \biggr) \end{align} The functions [[sumQ2q]] and [[sumQ4q]] provide the sum of the squared and quartic electric charges of a number [[nf]] of active quark flavors. <>= public :: beta0, beta1, beta2 public :: coeff_b0, coeff_b1, coeff_b2, coeffqed_b0, coeffqed_b1 - public :: sumQ2q, sumQ4q +<>= + pure module function beta0 (nf) + real(default), intent(in) :: nf + real(default) :: beta0 + end function beta0 + pure module function beta1 (nf) + real(default), intent(in) :: nf + real(default) :: beta1 + end function beta1 + pure module function beta2 (nf) + real(default), intent(in) :: nf + real(default) :: beta2 + end function beta2 + pure module function coeff_b0 (nf) + real(default), intent(in) :: nf + real(default) :: coeff_b0 + end function coeff_b0 + pure module function coeff_b1 (nf) + real(default), intent(in) :: nf + real(default) :: coeff_b1 + end function coeff_b1 + pure module function coeff_b2 (nf) + real(default), intent(in) :: nf + real(default) :: coeff_b2 + end function coeff_b2 + pure module function coeffqed_b0 (nf, nlep) + integer, intent(in) :: nf, nlep + real(default) :: n_lep, coeffqed_b0 + end function coeffqed_b0 + pure module function coeffqed_b1 (nf, nlep) + integer, intent(in) :: nf, nlep + real(default) :: n_lep, coeffqed_b1 + end function coeffqed_b1 <>= - pure function beta0 (nf) + pure module function beta0 (nf) real(default), intent(in) :: nf real(default) :: beta0 beta0 = 11.0_default - two/three * nf end function beta0 - pure function beta1 (nf) + pure module function beta1 (nf) real(default), intent(in) :: nf real(default) :: beta1 beta1 = 51.0_default - 19.0_default/three * nf end function beta1 - pure function beta2 (nf) + pure module function beta2 (nf) real(default), intent(in) :: nf real(default) :: beta2 beta2 = 2857.0_default - 5033.0_default / 9.0_default * & nf + 325.0_default/27.0_default * nf**2 end function beta2 - pure function coeff_b0 (nf) + pure module function coeff_b0 (nf) real(default), intent(in) :: nf real(default) :: coeff_b0 coeff_b0 = (11.0_default * CA - two * nf) / (12.0_default * pi) end function coeff_b0 - pure function coeff_b1 (nf) + pure module function coeff_b1 (nf) real(default), intent(in) :: nf real(default) :: coeff_b1 coeff_b1 = (17.0_default * CA**2 - five * CA * nf - three * CF * nf) / & (24.0_default * pi**2) end function coeff_b1 - pure function coeff_b2 (nf) + pure module function coeff_b2 (nf) real(default), intent(in) :: nf real(default) :: coeff_b2 coeff_b2 = (2857.0_default/54.0_default * CA**3 - & 1415.0_default/54.0_default * & CA**2 * nf - 205.0_default/18.0_default * CA*CF*nf & + 79.0_default/54.0_default * CA*nf**2 + & 11.0_default/9.0_default * CF * nf**2) / (four*pi)**3 end function coeff_b2 - pure function coeffqed_b0 (nf, nlep) + pure module function coeffqed_b0 (nf, nlep) integer, intent(in) :: nf, nlep real(default) :: n_lep, coeffqed_b0 n_lep = real(nlep, kind=default) coeffqed_b0 = - (three * sumQ2q (nf) + n_lep) / (three*pi) end function coeffqed_b0 - pure function coeffqed_b1 (nf, nlep) + pure module function coeffqed_b1 (nf, nlep) integer, intent(in) :: nf, nlep real(default) :: n_lep, coeffqed_b1 n_lep = real(nlep, kind=default) coeffqed_b1 = - (three * sumQ4q (nf) + n_lep) / (four*pi**2) end function coeffqed_b1 pure function sumQ2q (nf) integer, intent(in) :: nf real(default) :: sumQ2q select case (nf) case (0) sumQ2q = zero case (1) sumQ2q = 1.0_default/9.0_default case (2) sumQ2q = 5.0_default/9.0_default case (3) sumQ2q = 2.0_default/3.0_default case (4) sumQ2q = 10.0_default/9.0_default case (5) sumQ2q = 11.0_default/9.0_default case (6:) sumQ2q = 5.0_default/3.0_default end select end function sumQ2q pure function sumQ4q (nf) integer, intent(in) :: nf real(default) :: sumQ4q select case (nf) case (0) sumQ4q = zero case (1) sumQ4q = 1.0_default/81.0_default case (2) sumQ4q = 17.0_default/81.0_default case (3) sumQ4q = 2.0_default/9.0_default case (4) sumQ4q = 34.0_default/81.0_default case (5) sumQ4q = 35.0_default/81.0_default case (6:) sumQ4q = 17.0_default/27.0_default end select end function sumQ4q @ %def beta0 beta1 beta2 @ %def coeff_b0 coeff_b1 coeff_b2 coeffqed_b0 coeffqed_b1 @ %def sumQ2q sumQ4q @ There should be two versions of running $\alpha_s$, one which takes the scale and $\Lambda_{\text{QCD}}$ as input, and one which takes the scale and e.g. $\alpha_s(m_Z)$ as input. Here, we take the one which takes the QCD scale and scale as inputs from the PDG book. <>= public :: running_as, running_as_lam, running_alpha, running_alpha_num +<>= + pure module function running_as (scale, al_mz, mz, order, nf) result (ascale) + real(default), intent(in) :: scale + real(default), intent(in), optional :: al_mz, nf, mz + integer, intent(in), optional :: order + real(default) :: ascale + end function running_as + pure module function running_as_lam (nf, scale, lambda, order) result (ascale) + real(default), intent(in) :: nf, scale + real(default), intent(in), optional :: lambda + integer, intent(in), optional :: order + real(default) :: ascale + end function running_as_lam + pure module function running_alpha & + (scale, al_me, me, order, nf, nlep) result (ascale) + real(default), intent(in) :: scale + real(default), intent(in), optional :: al_me, me + integer, intent(in), optional :: order, nf, nlep + real(default) :: ascale + end function running_alpha + pure module function running_alpha_num & + (scale, al_me, me, order, nf, nlep) result (ascale) + real(default), intent(in) :: scale + real(default), intent(in), optional :: al_me, me + integer, intent(in), optional :: order, nf, nlep + real(default) :: ascale + end function running_alpha_num <>= - pure function running_as (scale, al_mz, mz, order, nf) result (ascale) + pure module function running_as (scale, al_mz, mz, order, nf) result (ascale) real(default), intent(in) :: scale real(default), intent(in), optional :: al_mz, nf, mz integer, intent(in), optional :: order integer :: ord real(default) :: az, m_z, as_log, n_f, b0, b1, b2, ascale real(default) :: as0, as1 if (present (mz)) then m_z = mz else m_z = MZ_REF end if if (present (order)) then ord = order else ord = 0 end if if (present (al_mz)) then az = al_mz else az = ALPHA_QCD_MZ_REF end if if (present (nf)) then n_f = nf else n_f = 5 end if b0 = coeff_b0 (n_f) b1 = coeff_b1 (n_f) b2 = coeff_b2 (n_f) as_log = one + b0 * az * log(scale**2/m_z**2) as0 = az / as_log as1 = as0 - as0**2 * b1/b0 * log(as_log) select case (ord) case (0) ascale = as0 case (1) ascale = as1 case (2) ascale = as1 + as0**3 * (b1**2/b0**2 * ((log(as_log))**2 - & log(as_log) + as_log - one) - b2/b0 * (as_log - one)) case default ascale = as0 end select end function running_as - pure function running_as_lam (nf, scale, lambda, order) result (ascale) + pure module function running_as_lam (nf, scale, lambda, order) result (ascale) real(default), intent(in) :: nf, scale real(default), intent(in), optional :: lambda integer, intent(in), optional :: order real(default) :: lambda_qcd real(default) :: as0, as1, logmul, b0, b1, b2, ascale integer :: ord if (present (lambda)) then lambda_qcd = lambda else lambda_qcd = LAMBDA_QCD_REF end if if (present (order)) then ord = order else ord = 0 end if b0 = beta0(nf) logmul = log(scale**2/lambda_qcd**2) as0 = four*pi / b0 / logmul if (ord > 0) then b1 = beta1(nf) as1 = as0 * (one - two* b1 / b0**2 * log(logmul) / logmul) end if select case (ord) case (0) ascale = as0 case (1) ascale = as1 case (2) b2 = beta2(nf) ascale = as1 + as0 * four * b1**2/b0**4/logmul**2 * & ((log(logmul) - 0.5_default)**2 + & b2*b0/8.0_default/b1**2 - five/four) case default ascale = as0 end select end function running_as_lam - pure function running_alpha & + pure module function running_alpha & (scale, al_me, me, order, nf, nlep) result (ascale) real(default), intent(in) :: scale real(default), intent(in), optional :: al_me, me integer, intent(in), optional :: order, nf, nlep integer :: ord, n_f, n_lep real(default) :: ae, m_e, a_log, b0, b1, ascale real(default) :: a0, a1 if (present (me)) then m_e = me else m_e = ME_REF end if if (present (order)) then ord = order else ord = 0 end if if (present (al_me)) then ae = al_me else ae = ALPHA_QED_ME_REF end if if (present (nf)) then n_f = nf else n_f = 5 end if if (present (nlep)) then n_lep = nlep else n_lep = 1 end if b0 = coeffqed_b0 (n_f, n_lep) b1 = coeffqed_b1 (n_f, n_lep) a_log = one + b0 * ae * log(scale**2/m_e**2) a0 = ae / a_log a1 = ae / (a_log + ae * b1/b0 * & log((a_log + ae * b1/b0)/(one + ae * b1/b0))) select case (ord) case (0) ascale = a0 case (1) ascale = a1 case default ascale = a0 end select end function running_alpha - pure function running_alpha_num & + pure module function running_alpha_num & (scale, al_me, me, order, nf, nlep) result (ascale) real(default), intent(in) :: scale real(default), intent(in), optional :: al_me, me integer, intent(in), optional :: order, nf, nlep integer, parameter :: n_steps = 20 integer :: ord, n_f, n_lep, k1 real(default), parameter :: sxth = 1._default/6._default real(default) :: ae, ascale, m_e, log_q, dlr, & b0, b1, xk0, xk1, xk2, xk3 if (present (order)) then ord = order else ord = 0 end if if (present (al_me)) then ae = al_me else ae = ALPHA_QED_ME_REF end if if (present (me)) then m_e = me else m_e = ME_REF end if if (present (nf)) then n_f = nf else n_f = 5 end if if (present (nlep)) then n_lep = nlep else n_lep = 1 end if ascale = ae log_q = log (scale**2/m_e**2) dlr = log_q / n_steps b0 = coeffqed_b0 (n_f, n_lep) b1 = coeffqed_b1 (n_f, n_lep) ! ..Solution of the evolution equation depending on ORD ! (fourth-order Runge-Kutta beyond the leading order) select case (ord) case (0) ascale = ae / (one + b0 * ae * log_q) case (1:) do k1 = 1, n_steps xk0 = dlr * beta_qed (ascale) xk1 = dlr * beta_qed (ascale + 0.5 * xk0) xk2 = dlr * beta_qed (ascale + 0.5 * xk1) xk3 = dlr * beta_qed (ascale + xk2) ascale = ascale + sxth * (xk0 + 2._default * xk1 + & 2._default * xk2 + xk3) end do end select contains pure function beta_qed (alpha) real(default), intent(in) :: alpha real(default) :: beta_qed beta_qed = - alpha**2 * (b0 + alpha * b1) end function beta_qed end function running_alpha_num @ %def running_as @ %def running_as_lam @ %def running_alpha running_alpha_num @ \subsection{Catani-Seymour Parameters} These are fundamental constants of the Catani-Seymour dipole formalism. Since the corresponding parameters for the gluon case depend on the number of flavors which is treated as an argument, there we do have functions and not parameters. \begin{equation} \gamma_q = \gamma_{\bar q} = \frac{3}{2} C_F \qquad \gamma_g = \frac{11}{6} C_A - \frac{2}{3} T_R N_f \end{equation} \begin{equation} K_q = K_{\bar q} = \left( \frac{7}{2} - \frac{\pi^2}{6} \right) C_F \qquad K_g = \left( \frac{67}{18} - \frac{\pi^2}{6} \right) C_A - \frac{10}{9} T_R N_f \end{equation} <>= - real(kind=default), parameter, public :: gamma_q = three/two * CF, & + real(default), parameter, public :: gamma_q = three/two * CF, & k_q = (7.0_default/two - pi**2/6.0_default) * CF @ %def gamma_q @ <>= public :: gamma_g, k_g +<>= + elemental module function gamma_g (nf) result (gg) + real(default), intent(in) :: nf + real(default) :: gg + end function gamma_g + elemental module function k_g (nf) result (kg) + real(default), intent(in) :: nf + real(default) :: kg + end function k_g <>= - elemental function gamma_g (nf) result (gg) - real(kind=default), intent(in) :: nf - real(kind=default) :: gg - gg = 11.0_default/6.0_default * CA - two/three * TR * nf + elemental module function gamma_g (nf) result (gg) + real(default), intent(in) :: nf + real(default) :: gg + gg = 11.0_default/6.0_default * CA - two/three * TR * nf end function gamma_g - elemental function k_g (nf) result (kg) - real(kind=default), intent(in) :: nf - real(kind=default) :: kg - kg = (67.0_default/18.0_default - pi**2/6.0_default) * CA - & - 10.0_default/9.0_default * TR * nf + elemental module function k_g (nf) result (kg) + real(default), intent(in) :: nf + real(default) :: kg + kg = (67.0_default/18.0_default - pi**2/6.0_default) * CA - & + 10.0_default/9.0_default * TR * nf end function k_g @ %def gamma_g @ %def k_g @ \subsection{Mathematical Functions} The dilogarithm. This simplified version is bound to double precision, and restricted to argument values less or equal to unity, so we do not need complex algebra. The wrapper converts it to default precision (which is, of course, a no-op if double=default). The routine calculates the dilogarithm through mapping on the area where there is a quickly convergent series (adapted from an F77 routine by Hans Kuijf, 1988): Map $x$ such that $x$ is not in the neighbourhood of $1$. Note that $|z|=-\ln(1-x)$ is always smaller than $1.10$, but $\frac{1.10^{19}}{19!}{\rm Bernoulli}_{19}=2.7\times 10^{-15}$. <>= public :: Li2 -<>= - elemental function Li2 (x) - use kinds, only: double +<>= + elemental module function Li2 (x) real(default), intent(in) :: x real(default) :: Li2 - Li2 = real( Li2_double (real(x, kind=double)), kind=default) + end function Li2 +<>= + elemental module function Li2 (x) + real(default), intent(in) :: x + real(default) :: Li2 + Li2 = real( Li2_double (real(x, kind=double)), kind=default) end function Li2 @ %def: Li2 @ <>= elemental function Li2_double (x) result (Li2) - use kinds, only: double - real(kind=double), intent(in) :: x - real(kind=double) :: Li2 - real(kind=double), parameter :: pi2_6 = pi**2/6 + real(double), intent(in) :: x + real(double) :: Li2 + real(double), parameter :: pi2_6 = pi**2/6 if (abs(1-x) < tiny_07) then Li2 = pi2_6 else if (abs(1-x) < 0.5_double) then Li2 = pi2_6 - log(1-x) * log(x) - Li2_restricted (1-x) else if (abs(x) > 1.d0) then ! Li2 = 0 ! call msg_bug (" Dilogarithm called outside of defined range.") !!! Reactivate Dilogarithm identity Li2 = -pi2_6 - 0.5_default * log(-x) * log(-x) - Li2_restricted (1/x) else Li2 = Li2_restricted (x) end if contains elemental function Li2_restricted (x) result (Li2) - real(kind=double), intent(in) :: x - real(kind=double) :: Li2 - real(kind=double) :: tmp, z, z2 + real(double), intent(in) :: x + real(double) :: Li2 + real(double) :: tmp, z, z2 z = - log (1-x) z2 = z**2 ! Horner's rule for the powers z^3 through z^19 tmp = 43867._double/798._double tmp = tmp * z2 /342._double - 3617._double/510._double tmp = tmp * z2 /272._double + 7._double/6._double tmp = tmp * z2 /210._double - 691._double/2730._double tmp = tmp * z2 /156._double + 5._double/66._double tmp = tmp * z2 /110._double - 1._double/30._double tmp = tmp * z2 / 72._double + 1._double/42._double tmp = tmp * z2 / 42._double - 1._double/30._double tmp = tmp * z2 / 20._double + 1._double/6._double ! The first three terms of the power series Li2 = z2 * z * tmp / 6._double - 0.25_double * z2 + z end function Li2_restricted end function Li2_double @ %def Li2_double @ Complex digamma function. For this we use the asymptotic formula in Abramoqicz/Stegun, Eq. (6.3.18), and the recurrence formula Eq. (6.3.6): \begin{equation} \psi^{(0})(z) := \psi(z) = \frac{\Gamma'(z)}{\Gamma(z)} \end{equation} <>= public :: psic +<>= + elemental module function psic (z) result (psi) + complex(default), intent(in) :: z + complex(default) :: psi + end function psic <>= - elemental function psic (z) result (psi) + elemental module function psic (z) result (psi) complex(default), intent(in) :: z complex(default) :: psi complex(default) :: shift, zz, zi, zi2 shift = 0 zz = z if (abs (aimag(zz)) < 10._default) then do while (abs (zz) < 10._default) shift = shift - 1 / zz zz = zz + 1 end do end if zi = 1/zz zi2 = zi*zi psi = shift + log(zz) - zi/2 - zi2 / 5040._default * ( 420._default + & zi2 * ( -42._default + zi2 * (20._default - 21._default * zi2))) end function psic @ %def psic @ Complex polygamma function. For this we use the asymptotic formula in Abramoqicz/Stegun, Eq. (6.4.11), and the recurrence formula Eq. (6.4.11): \begin{equation} \psi^{(m})(z) := \frac{d^m}{dz^m} \psi(z) = \frac{d^{m+1}}{dz^{m+1}} \ln \Gamma(z) \end{equation} <>= public :: psim +<>= + elemental module function psim (z, m) result (psi) + complex(default), intent(in) :: z + integer, intent(in) :: m + complex(default) :: psi + end function psim <>= - elemental function psim (z, m) result (psi) + elemental module function psim (z, m) result (psi) complex(default), intent(in) :: z integer, intent(in) :: m complex(default) :: psi complex(default) :: shift, rec, zz, zi, zi2 real(default) :: c1, c2, c3, c4, c5, c6, c7 integer :: i if (m < 1) then psi = psic(z) else shift = 0 zz = z if (abs (aimag (zz)) < 10._default) then CHECK_ABS: do i = 1, m rec = (-1)**m * factorial (m) / zz**(m+1) shift = shift - rec zz = zz + 1 if (abs (zz) > 10._default) exit CHECK_ABS end do CHECK_ABS end if c1 = 1._default c2 = 1._default / 2._default c3 = 1._default / 6._default c4 = - 1._default / 30._default c5 = 1._default / 42._default c6 = - 1._default / 30._default c7 = 5._default / 66._default do i = 2, m c1 = c1 * (i-1) c2 = c2 * i c3 = c3 * (i+1) c4 = c4 * (i+3) c5 = c5 * (i+5) c6 = c6 * (i+7) c7 = c7 * (i+9) end do zi = 1/zz zi2 = zi*zi psi = shift + (-1)**(m-1) * zi**m * ( c1 + zi * ( c2 + zi * ( & c3 + zi2 * ( c4 + zi2 * ( c5 + zi2 * ( c6 + zi2 * ( c7 * zi2))))))) end if end function psim @ %def psim @ Nielsen's generalized polylogarithms, \begin{equation*} S_{n,m}(x) = \frac{(-1)^{n+m-1}}{(n-1)!m!} \int_0^1 t^{-1} \; \ln^{n-1} t \; \ln^m (1-xt) \; dt \; , \end{equation*} adapted from the CERNLIB function [[wgplg]] for real arguments [[x]] and integer $n$ and $m$ satisfying $1 \leq n \leq 4$, $1 \leq m \leq 4$, $n+m \leq 5$, i.e. one of the functions $S_{1,1}$, $S_{1,2}$, $S_{2,1}$, $S_{1,3}$, $S_{2,2}$, $S_{3,1}$, $S_{1,4}$, $S_{2,3}$, $S_{3,2}$, $S_{4,1}$. If $x\leq1$, $S_{n,m}(x)$ is real, and the imaginary part is set to zero. <>= public :: cnielsen public :: nielsen +<>= + module function cnielsen (n, m, x) result (nplog) + integer, intent(in) :: n, m + real(default), intent(in) :: x + complex(default) :: nplog + end function cnielsen + module function nielsen (n, m, x) result (nplog) + integer, intent(in) :: n, m + real(default), intent(in) :: x + real(default) :: nplog + end function nielsen <>= - function cnielsen (n, m, x) result (nplog) + module function cnielsen (n, m, x) result (nplog) integer, intent(in) :: n, m real(default), intent(in) :: x complex(default) :: nplog real(default), parameter :: c1 = 4._default/3._default, & c2 = 1._default/3._default real(default), dimension(0:4), parameter :: & fct = [1.0_default,1.0_default,2.0_default,6.0_default,24.0_default] real(default), dimension(4,4) :: s1, cc real(default), dimension(0:30,10) :: aa complex(default), dimension(0:5) :: vv real(default), dimension(0:5) :: uu real(default) :: x1, h, alfa, b0, b1, b2, qq, rr complex(default) :: sj, sk integer, dimension(10), parameter :: & nc = [24,26,28,30,22,24,26,19,22,17] integer, dimension(31), parameter :: & index = [1,2,3,4,0,0,0,0,0,0,5,6,7,0,0,0,0,0,0,0, & 8,9,0,0,0,0,0,0,0,0,10] real(default), dimension(0:4), parameter :: & sgn = [1._default, -1._default, 1._default, -1._default, 1._default] integer :: it, j, k, l, m1, n1 if ((n<1) .or. (n>4) .or. (m<1) .or. (m>4) .or. (n+m > 5)) then call msg_fatal & ("The Nielsen dilogarithms cannot be applied for these values.") end if s1 = 0._default s1(1,1) = 1.6449340668482_default s1(1,2) = 1.2020569031596_default s1(1,3) = 1.0823232337111_default s1(1,4) = 1.0369277551434_default s1(2,1) = 1.2020569031596_default s1(2,2) = 2.7058080842778e-1_default s1(2,3) = 9.6551159989444e-2_default s1(3,1) = 1.0823232337111_default s1(3,2) = 9.6551159989444e-2_default s1(4,1) = 1.0369277551434_default cc = 0._default cc(1,1) = 1.6449340668482_default cc(1,2) = 1.2020569031596_default cc(1,3) = 1.0823232337111_default cc(1,4) = 1.0369277551434_default cc(2,2) =-1.8940656589945_default cc(2,3) =-3.0142321054407_default cc(3,1) = 1.8940656589945_default cc(3,2) = 3.0142321054407_default aa = 0._default aa( 0,1) = 0.96753215043498_default aa( 1,1) = 0.16607303292785_default aa( 2,1) = 0.02487932292423_default aa( 3,1) = 0.00468636195945_default aa( 4,1) = 0.00100162749616_default aa( 5,1) = 0.00023200219609_default aa( 6,1) = 0.00005681782272_default aa( 7,1) = 0.00001449630056_default aa( 8,1) = 0.00000381632946_default aa( 9,1) = 0.00000102990426_default aa(10,1) = 0.00000028357538_default aa(11,1) = 0.00000007938705_default aa(12,1) = 0.00000002253670_default aa(13,1) = 0.00000000647434_default aa(14,1) = 0.00000000187912_default aa(15,1) = 0.00000000055029_default aa(16,1) = 0.00000000016242_default aa(17,1) = 0.00000000004827_default aa(18,1) = 0.00000000001444_default aa(19,1) = 0.00000000000434_default aa(20,1) = 0.00000000000131_default aa(21,1) = 0.00000000000040_default aa(22,1) = 0.00000000000012_default aa(23,1) = 0.00000000000004_default aa(24,1) = 0.00000000000001_default aa( 0,2) = 0.95180889127832_default aa( 1,2) = 0.43131131846532_default aa( 2,2) = 0.10002250714905_default aa( 3,2) = 0.02442415595220_default aa( 4,2) = 0.00622512463724_default aa( 5,2) = 0.00164078831235_default aa( 6,2) = 0.00044407920265_default aa( 7,2) = 0.00012277494168_default aa( 8,2) = 0.00003453981284_default aa( 9,2) = 0.00000985869565_default aa(10,2) = 0.00000284856995_default aa(11,2) = 0.00000083170847_default aa(12,2) = 0.00000024503950_default aa(13,2) = 0.00000007276496_default aa(14,2) = 0.00000002175802_default aa(15,2) = 0.00000000654616_default aa(16,2) = 0.00000000198033_default aa(17,2) = 0.00000000060204_default aa(18,2) = 0.00000000018385_default aa(19,2) = 0.00000000005637_default aa(20,2) = 0.00000000001735_default aa(21,2) = 0.00000000000536_default aa(22,2) = 0.00000000000166_default aa(23,2) = 0.00000000000052_default aa(24,2) = 0.00000000000016_default aa(25,2) = 0.00000000000005_default aa(26,2) = 0.00000000000002_default aa( 0,3) = 0.98161027991365_default aa( 1,3) = 0.72926806320726_default aa( 2,3) = 0.22774714909321_default aa( 3,3) = 0.06809083296197_default aa( 4,3) = 0.02013701183064_default aa( 5,3) = 0.00595478480197_default aa( 6,3) = 0.00176769013959_default aa( 7,3) = 0.00052748218502_default aa( 8,3) = 0.00015827461460_default aa( 9,3) = 0.00004774922076_default aa(10,3) = 0.00001447920408_default aa(11,3) = 0.00000441154886_default aa(12,3) = 0.00000135003870_default aa(13,3) = 0.00000041481779_default aa(14,3) = 0.00000012793307_default aa(15,3) = 0.00000003959070_default aa(16,3) = 0.00000001229055_default aa(17,3) = 0.00000000382658_default aa(18,3) = 0.00000000119459_default aa(19,3) = 0.00000000037386_default aa(20,3) = 0.00000000011727_default aa(21,3) = 0.00000000003687_default aa(22,3) = 0.00000000001161_default aa(23,3) = 0.00000000000366_default aa(24,3) = 0.00000000000116_default aa(25,3) = 0.00000000000037_default aa(26,3) = 0.00000000000012_default aa(27,3) = 0.00000000000004_default aa(28,3) = 0.00000000000001_default aa( 0,4) = 1.0640521184614_default aa( 1,4) = 1.0691720744981_default aa( 2,4) = 0.41527193251768_default aa( 3,4) = 0.14610332936222_default aa( 4,4) = 0.04904732648784_default aa( 5,4) = 0.01606340860396_default aa( 6,4) = 0.00518889350790_default aa( 7,4) = 0.00166298717324_default aa( 8,4) = 0.00053058279969_default aa( 9,4) = 0.00016887029251_default aa(10,4) = 0.00005368328059_default aa(11,4) = 0.00001705923313_default aa(12,4) = 0.00000542174374_default aa(13,4) = 0.00000172394082_default aa(14,4) = 0.00000054853275_default aa(15,4) = 0.00000017467795_default aa(16,4) = 0.00000005567550_default aa(17,4) = 0.00000001776234_default aa(18,4) = 0.00000000567224_default aa(19,4) = 0.00000000181313_default aa(20,4) = 0.00000000058012_default aa(21,4) = 0.00000000018579_default aa(22,4) = 0.00000000005955_default aa(23,4) = 0.00000000001911_default aa(24,4) = 0.00000000000614_default aa(25,4) = 0.00000000000197_default aa(26,4) = 0.00000000000063_default aa(27,4) = 0.00000000000020_default aa(28,4) = 0.00000000000007_default aa(29,4) = 0.00000000000002_default aa(30,4) = 0.00000000000001_default aa( 0,5) = 0.97920860669175_default aa( 1,5) = 0.08518813148683_default aa( 2,5) = 0.00855985222013_default aa( 3,5) = 0.00121177214413_default aa( 4,5) = 0.00020722768531_default aa( 5,5) = 0.00003996958691_default aa( 6,5) = 0.00000838064065_default aa( 7,5) = 0.00000186848945_default aa( 8,5) = 0.00000043666087_default aa( 9,5) = 0.00000010591733_default aa(10,5) = 0.00000002647892_default aa(11,5) = 0.00000000678700_default aa(12,5) = 0.00000000177654_default aa(13,5) = 0.00000000047342_default aa(14,5) = 0.00000000012812_default aa(15,5) = 0.00000000003514_default aa(16,5) = 0.00000000000975_default aa(17,5) = 0.00000000000274_default aa(18,5) = 0.00000000000077_default aa(19,5) = 0.00000000000022_default aa(20,5) = 0.00000000000006_default aa(21,5) = 0.00000000000002_default aa(22,5) = 0.00000000000001_default aa( 0,6) = 0.95021851963952_default aa( 1,6) = 0.29052529161433_default aa( 2,6) = 0.05081774061716_default aa( 3,6) = 0.00995543767280_default aa( 4,6) = 0.00211733895031_default aa( 5,6) = 0.00047859470550_default aa( 6,6) = 0.00011334321308_default aa( 7,6) = 0.00002784733104_default aa( 8,6) = 0.00000704788108_default aa( 9,6) = 0.00000182788740_default aa(10,6) = 0.00000048387492_default aa(11,6) = 0.00000013033842_default aa(12,6) = 0.00000003563769_default aa(13,6) = 0.00000000987174_default aa(14,6) = 0.00000000276586_default aa(15,6) = 0.00000000078279_default aa(16,6) = 0.00000000022354_default aa(17,6) = 0.00000000006435_default aa(18,6) = 0.00000000001866_default aa(19,6) = 0.00000000000545_default aa(20,6) = 0.00000000000160_default aa(21,6) = 0.00000000000047_default aa(22,6) = 0.00000000000014_default aa(23,6) = 0.00000000000004_default aa(24,6) = 0.00000000000001_default aa( 0,7) = 0.95064032186777_default aa( 1,7) = 0.54138285465171_default aa( 2,7) = 0.13649979590321_default aa( 3,7) = 0.03417942328207_default aa( 4,7) = 0.00869027883583_default aa( 5,7) = 0.00225284084155_default aa( 6,7) = 0.00059516089806_default aa( 7,7) = 0.00015995617766_default aa( 8,7) = 0.00004365213096_default aa( 9,7) = 0.00001207474688_default aa(10,7) = 0.00000338018176_default aa(11,7) = 0.00000095632476_default aa(12,7) = 0.00000027313129_default aa(13,7) = 0.00000007866968_default aa(14,7) = 0.00000002283195_default aa(15,7) = 0.00000000667205_default aa(16,7) = 0.00000000196191_default aa(17,7) = 0.00000000058018_default aa(18,7) = 0.00000000017246_default aa(19,7) = 0.00000000005151_default aa(20,7) = 0.00000000001545_default aa(21,7) = 0.00000000000465_default aa(22,7) = 0.00000000000141_default aa(23,7) = 0.00000000000043_default aa(24,7) = 0.00000000000013_default aa(25,7) = 0.00000000000004_default aa(26,7) = 0.00000000000001_default aa( 0,8) = 0.98800011672229_default aa( 1,8) = 0.04364067609601_default aa( 2,8) = 0.00295091178278_default aa( 3,8) = 0.00031477809720_default aa( 4,8) = 0.00004314846029_default aa( 5,8) = 0.00000693818230_default aa( 6,8) = 0.00000124640350_default aa( 7,8) = 0.00000024293628_default aa( 8,8) = 0.00000005040827_default aa( 9,8) = 0.00000001099075_default aa(10,8) = 0.00000000249467_default aa(11,8) = 0.00000000058540_default aa(12,8) = 0.00000000014127_default aa(13,8) = 0.00000000003492_default aa(14,8) = 0.00000000000881_default aa(15,8) = 0.00000000000226_default aa(16,8) = 0.00000000000059_default aa(17,8) = 0.00000000000016_default aa(18,8) = 0.00000000000004_default aa(19,8) = 0.00000000000001_default aa( 0,9) = 0.95768506546350_default aa( 1,9) = 0.19725249679534_default aa( 2,9) = 0.02603370313918_default aa( 3,9) = 0.00409382168261_default aa( 4,9) = 0.00072681707110_default aa( 5,9) = 0.00014091879261_default aa( 6,9) = 0.00002920458914_default aa( 7,9) = 0.00000637631144_default aa( 8,9) = 0.00000145167850_default aa( 9,9) = 0.00000034205281_default aa(10,9) = 0.00000008294302_default aa(11,9) = 0.00000002060784_default aa(12,9) = 0.00000000522823_default aa(13,9) = 0.00000000135066_default aa(14,9) = 0.00000000035451_default aa(15,9) = 0.00000000009436_default aa(16,9) = 0.00000000002543_default aa(17,9) = 0.00000000000693_default aa(18,9) = 0.00000000000191_default aa(19,9) = 0.00000000000053_default aa(20,9) = 0.00000000000015_default aa(21,9) = 0.00000000000004_default aa(22,9) = 0.00000000000001_default aa( 0,10) = 0.99343651671347_default aa( 1,10) = 0.02225770126826_default aa( 2,10) = 0.00101475574703_default aa( 3,10) = 0.00008175156250_default aa( 4,10) = 0.00000899973547_default aa( 5,10) = 0.00000120823987_default aa( 6,10) = 0.00000018616913_default aa( 7,10) = 0.00000003174723_default aa( 8,10) = 0.00000000585215_default aa( 9,10) = 0.00000000114739_default aa(10,10) = 0.00000000023652_default aa(11,10) = 0.00000000005082_default aa(12,10) = 0.00000000001131_default aa(13,10) = 0.00000000000259_default aa(14,10) = 0.00000000000061_default aa(15,10) = 0.00000000000015_default aa(16,10) = 0.00000000000004_default aa(17,10) = 0.00000000000001_default if (x == 1._default) then nplog = s1(n,m) else if (x > 2._default .or. x < -1.0_default) then x1 = 1._default / x h = c1 * x1 + c2 alfa = h + h vv(0) = 1._default if (x < -1.0_default) then vv(1) = log(-x) else if (x > 2._default) then vv(1) = log(cmplx(-x,0._default,kind=default)) end if do l = 2, n+m vv(l) = vv(1) * vv(l-1)/l end do sk = 0._default do k = 0, m-1 m1 = m-k rr = x1**m1 / (fct(m1) * fct(n-1)) sj = 0._default do j = 0, k n1 = n+k-j l = index(10*n1+m1-10) b1 = 0._default b2 = 0._default do it = nc(l), 0, -1 b0 = aa(it,l) + alfa*b1 - b2 b2 = b1 b1 = b0 end do qq = (fct(n1-1) / fct(k-j)) * (b0 - h*b2) * rr / m1**n1 sj = sj + vv(j) * qq end do sk = sk + sgn(k) * sj end do sj = 0._default do j = 0, n-1 sj = sj + vv(j) * cc(n-j,m) end do nplog = sgn(n) * sk + sgn(m) * (sj + vv(n+m)) else if (x > 0.5_default) then x1 = 1._default - x h = c1 * x1 + c2 alfa = h + h vv(0) = 1._default uu(0) = 1._default vv(1) = log(cmplx(x1,0._default,kind=default)) uu(1) = log(x) do l = 2, m vv(l) = vv(1) * vv(l-1) / l end do do l = 2, n uu(l) = uu(1) * uu(l-1) / l end do sk = 0._default do k = 0, n-1 m1 = n-k rr = x1**m1 / fct(m1) sj = 0._default do j = 0, m-1 n1 = m-j l = index(10*n1 + m1 - 10) b1 = 0._default b2 = 0._default do it = nc(l), 0, -1 b0 = aa(it,l) + alfa*b1 - b2 b2 = b1 b1 = b0 end do qq = sgn(j) * (b0 - h*b2) * rr / m1**n1 sj = sj + vv(j) * qq end do sk = sk + uu(k) * (s1(m1,m) - sj) end do nplog = sk + sgn(m) * uu(n) * vv(m) else l = index(10*n + m - 10) h = c1 * x + c2 alfa = h + h b1 = 0._default b2 = 0._default do it = nc(l), 0, -1 b0 = aa(it,l) + alfa*b1 - b2 b2 = b1 b1 = b0 end do nplog = (b0 - h*b2) * x**m / (fct(m) * m**n) end if end function cnielsen - function nielsen (n, m, x) result (nplog) + module function nielsen (n, m, x) result (nplog) integer, intent(in) :: n, m real(default), intent(in) :: x real(default) :: nplog nplog = real (cnielsen (n, m, x)) end function nielsen @ %def cnielsen nielsen @ $\text{Li}_{n}(x) = S_{n-1,1}(x)$. <>= public :: polylog +<>= + module function polylog (n, x) result (plog) + integer, intent(in) :: n + real(default), intent(in) :: x + real(default) :: plog + end function polylog <>= - function polylog (n, x) result (plog) + module function polylog (n, x) result (plog) integer, intent(in) :: n real(default), intent(in) :: x real(default) :: plog plog = nielsen (n-1,1,x) end function polylog @ %def polylog @ $\text{Li}_2(x)$. <>= public :: dilog +<>= + module function dilog (x) result (dlog) + real(default), intent(in) :: x + real(default) :: dlog + end function dilog <>= - function dilog (x) result (dlog) + module function dilog (x) result (dlog) real(default), intent(in) :: x real(default) :: dlog dlog = polylog (2,x) end function dilog @ %def dilog @ $\text{Li}_3(x)$. <>= public :: trilog +<>= + module function trilog (x) result (tlog) + real(default), intent(in) :: x + real(default) :: tlog + end function trilog <>= - function trilog (x) result (tlog) + module function trilog (x) result (tlog) real(default), intent(in) :: x real(default) :: tlog tlog = polylog (3,x) end function trilog @ %def trilog @ \subsection{Loop Integrals} These functions appear in the calculation of the effective one-loop coupling of a (pseudo)scalar to a vector boson pair. <>= public :: faux +<>= + elemental module function faux (x) result (y) + real(default), intent(in) :: x + complex(default) :: y + end function faux <>= - elemental function faux (x) result (y) + elemental module function faux (x) result (y) real(default), intent(in) :: x complex(default) :: y if (1 <= x) then y = asin(sqrt(1/x))**2 else y = - 1/4.0_default * (log((1 + sqrt(1 - x))/ & (1 - sqrt(1 - x))) - cmplx (0.0_default, pi, kind=default))**2 end if end function faux @ %def faux @ <>= public :: fonehalf +<>= + elemental module function fonehalf (x) result (y) + real(default), intent(in) :: x + complex(default) :: y + end function fonehalf <>= - elemental function fonehalf (x) result (y) + elemental module function fonehalf (x) result (y) real(default), intent(in) :: x complex(default) :: y if (abs(x) < eps0) then y = 0 else y = - 2.0_default * x * (1 + (1 - x) * faux(x)) end if end function fonehalf @ %def fonehalf @ <>= public :: fonehalf_pseudo +<>= + module function fonehalf_pseudo (x) result (y) + real(default), intent(in) :: x + complex(default) :: y + end function fonehalf_pseudo <>= - function fonehalf_pseudo (x) result (y) + module function fonehalf_pseudo (x) result (y) real(default), intent(in) :: x complex(default) :: y if (abs(x) < eps0) then y = 0 else y = - 2.0_default * x * faux(x) end if end function fonehalf_pseudo @ %def fonehalf_pseudo @ <>= public :: fone +<>= + elemental module function fone (x) result (y) + real(default), intent(in) :: x + complex(default) :: y + end function fone <>= - elemental function fone (x) result (y) + elemental module function fone (x) result (y) real(default), intent(in) :: x complex(default) :: y if (abs(x) < eps0) then y = 2.0_default else y = 2.0_default + 3.0_default * x + & 3.0_default * x * (2.0_default - x) * & faux(x) end if end function fone @ %def fone @ <>= public :: gaux +<>= + elemental module function gaux (x) result (y) + real(default), intent(in) :: x + complex(default) :: y + end function gaux <>= - elemental function gaux (x) result (y) + elemental module function gaux (x) result (y) real(default), intent(in) :: x complex(default) :: y if (1 <= x) then y = sqrt(x - 1) * asin(sqrt(1/x)) else y = sqrt(1 - x) * (log((1 + sqrt(1 - x)) / & (1 - sqrt(1 - x))) - & cmplx (0.0_default, pi, kind=default)) / 2.0_default end if end function gaux @ %def gaux @ <>= public :: tri_i1 +<>= + elemental module function tri_i1 (a,b) result (y) + real(default), intent(in) :: a,b + complex(default) :: y + end function tri_i1 <>= - elemental function tri_i1 (a,b) result (y) + elemental module function tri_i1 (a,b) result (y) real(default), intent(in) :: a,b complex(default) :: y if (a < eps0 .or. b < eps0) then y = 0 else y = a*b/2.0_default/(a-b) + a**2 * b**2/2.0_default/(a-b)**2 * & (faux(a) - faux(b)) + & a**2 * b/(a-b)**2 * (gaux(a) - gaux(b)) end if end function tri_i1 @ %def tri_i1 @ <>= public :: tri_i2 +<>= + elemental module function tri_i2 (a,b) result (y) + real(default), intent(in) :: a,b + complex(default) :: y + end function tri_i2 <>= - elemental function tri_i2 (a,b) result (y) + elemental module function tri_i2 (a,b) result (y) real(default), intent(in) :: a,b complex(default) :: y if (a < eps0 .or. b < eps0) then y = 0 else y = - a * b / 2.0_default / (a-b) * (faux(a) - faux(b)) end if end function tri_i2 @ %def tri_i2 @ \subsection{More on $\alpha_s$} These functions are for the running of the strong coupling constants, $\alpha_s$. <>= public :: run_b0 +<>= + elemental module function run_b0 (nf) result (bnull) + integer, intent(in) :: nf + real(default) :: bnull + end function run_b0 <>= - elemental function run_b0 (nf) result (bnull) + elemental module function run_b0 (nf) result (bnull) integer, intent(in) :: nf real(default) :: bnull bnull = 33.0_default - 2.0_default * nf end function run_b0 @ %def run_b0 @ <>= public :: run_b1 -<>= - elemental function run_b1 (nf) result (bone) +<>= + elemental module function run_b1 (nf) result (bone) integer, intent(in) :: nf real(default) :: bone - bone = 6.0_default * (153.0_default - 19.0_default * nf)/run_b0(nf)**2 + end function run_b1 +<>= + elemental module function run_b1 (nf) result (bone) + integer, intent(in) :: nf + real(default) :: bone + bone = 6.0_default * (153.0_default - 19.0_default * nf)/run_b0(nf)**2 end function run_b1 @ %def run_b1 @ <>= public :: run_aa +<>= + elemental module function run_aa (nf) result (aaa) + integer, intent(in) :: nf + real(default) :: aaa + end function run_aa <>= - elemental function run_aa (nf) result (aaa) - integer, intent(in) :: nf - real(default) :: aaa - aaa = 12.0_default * PI / run_b0(nf) + elemental module function run_aa (nf) result (aaa) + integer, intent(in) :: nf + real(default) :: aaa + aaa = 12.0_default * PI / run_b0(nf) end function run_aa @ %def run_aa @ <>= public :: run_bb <>= elemental function run_bb (nf) result (bbb) integer, intent(in) :: nf real(default) :: bbb bbb = run_b1(nf) / run_aa(nf) end function run_bb @ %def run_bb @ \subsection{Functions for Catani-Seymour dipoles} For the automated Catani-Seymour dipole subtraction, we need the following functions. <>= public :: ff_dipole -<>= - pure subroutine ff_dipole (v_ijk,y_ijk,p_ij,pp_k,p_i,p_j,p_k) +<>= + pure module subroutine ff_dipole (v_ijk, y_ijk, p_ij, pp_k, p_i, p_j, p_k) type(vector4_t), intent(in) :: p_i, p_j, p_k type(vector4_t), intent(out) :: p_ij, pp_k - real(kind=default), intent(out) :: y_ijk - real(kind=default) :: z_i - real(kind=default), intent(out) :: v_ijk - z_i = (p_i*p_k) / ((p_k*p_j) + (p_k*p_i)) - y_ijk = (p_i*p_j) / ((p_i*p_j) + (p_i*p_k) + (p_j*p_k)) - p_ij = p_i + p_j - y_ijk/(1.0_default - y_ijk) * p_k - pp_k = (1.0/(1.0_default - y_ijk)) * p_k - !!! We don't multiply by alpha_s right here: - v_ijk = 8.0_default * PI * CF * & - (2.0 / (1.0 - z_i*(1.0 - y_ijk)) - (1.0 + z_i)) + real(default), intent(out) :: y_ijk + real(default), intent(out) :: v_ijk + end subroutine ff_dipole +<>= + pure module subroutine ff_dipole (v_ijk, y_ijk, p_ij, pp_k, p_i, p_j, p_k) + type(vector4_t), intent(in) :: p_i, p_j, p_k + type(vector4_t), intent(out) :: p_ij, pp_k + real(default), intent(out) :: y_ijk + real(default) :: z_i + real(default), intent(out) :: v_ijk + z_i = (p_i*p_k) / ((p_k*p_j) + (p_k*p_i)) + y_ijk = (p_i*p_j) / ((p_i*p_j) + (p_i*p_k) + (p_j*p_k)) + p_ij = p_i + p_j - y_ijk/(1.0_default - y_ijk) * p_k + pp_k = (1.0/(1.0_default - y_ijk)) * p_k + !!! We don't multiply by alpha_s right here: + v_ijk = 8.0_default * PI * CF * & + (2.0 / (1.0 - z_i*(1.0 - y_ijk)) - (1.0 + z_i)) end subroutine ff_dipole @ %def ff_dipole @ <>= public :: fi_dipole -<>= - pure subroutine fi_dipole (v_ija,x_ija,p_ij,pp_a,p_i,p_j,p_a) - type(vector4_t), intent(in) :: p_i, p_j, p_a - type(vector4_t), intent(out) :: p_ij, pp_a - real(kind=default), intent(out) :: x_ija - real(kind=default) :: z_i - real(kind=default), intent(out) :: v_ija - z_i = (p_i*p_a) / ((p_a*p_j) + (p_a*p_i)) - x_ija = ((p_i*p_a) + (p_j*p_a) - (p_i*p_j)) & - / ((p_i*p_a) + (p_j*p_a)) - p_ij = p_i + p_j - (1.0_default - x_ija) * p_a - pp_a = x_ija * p_a - !!! We don't not multiply by alpha_s right here: - v_ija = 8.0_default * PI * CF * & - (2.0 / (1.0 - z_i + (1.0 - x_ija)) - (1.0 + z_i)) / x_ija +<>= + pure module subroutine fi_dipole (v_ija, x_ija, p_ij, pp_a, p_i, p_j, p_a) + type(vector4_t), intent(in) :: p_i, p_j, p_a + type(vector4_t), intent(out) :: p_ij, pp_a + real(default), intent(out) :: x_ija + real(default), intent(out) :: v_ija + end subroutine fi_dipole +<>= + pure module subroutine fi_dipole (v_ija, x_ija, p_ij, pp_a, p_i, p_j, p_a) + type(vector4_t), intent(in) :: p_i, p_j, p_a + type(vector4_t), intent(out) :: p_ij, pp_a + real(default), intent(out) :: x_ija + real(default) :: z_i + real(default), intent(out) :: v_ija + z_i = (p_i*p_a) / ((p_a*p_j) + (p_a*p_i)) + x_ija = ((p_i*p_a) + (p_j*p_a) - (p_i*p_j)) & + / ((p_i*p_a) + (p_j*p_a)) + p_ij = p_i + p_j - (1.0_default - x_ija) * p_a + pp_a = x_ija * p_a + !!! We don't not multiply by alpha_s right here: + v_ija = 8.0_default * PI * CF * & + (2.0 / (1.0 - z_i + (1.0 - x_ija)) - (1.0 + z_i)) / x_ija end subroutine fi_dipole @ %def fi_dipole @ <>= public :: if_dipole -<>= - pure subroutine if_dipole (v_kja,u_j,p_aj,pp_k,p_k,p_j,p_a) - type(vector4_t), intent(in) :: p_k, p_j, p_a - type(vector4_t), intent(out) :: p_aj, pp_k - real(kind=default), intent(out) :: u_j - real(kind=default) :: x_kja - real(kind=default), intent(out) :: v_kja - u_j = (p_a*p_j) / ((p_a*p_j) + (p_a*p_k)) - x_kja = ((p_a*p_k) + (p_a*p_j) - (p_j*p_k)) & - / ((p_a*p_j) + (p_a*p_k)) - p_aj = x_kja * p_a - pp_k = p_k + p_j - (1.0_default - x_kja) * p_a - v_kja = 8.0_default * PI * CF * & - (2.0 / (1.0 - x_kja + u_j) - (1.0 + x_kja)) / x_kja +<>= + pure module subroutine if_dipole (v_kja, u_j, p_aj, pp_k, p_k, p_j, p_a) + type(vector4_t), intent(in) :: p_k, p_j, p_a + type(vector4_t), intent(out) :: p_aj, pp_k + real(default), intent(out) :: u_j + real(default), intent(out) :: v_kja + end subroutine if_dipole +<>= + pure module subroutine if_dipole (v_kja, u_j, p_aj, pp_k, p_k, p_j, p_a) + type(vector4_t), intent(in) :: p_k, p_j, p_a + type(vector4_t), intent(out) :: p_aj, pp_k + real(default), intent(out) :: u_j + real(default) :: x_kja + real(default), intent(out) :: v_kja + u_j = (p_a*p_j) / ((p_a*p_j) + (p_a*p_k)) + x_kja = ((p_a*p_k) + (p_a*p_j) - (p_j*p_k)) & + / ((p_a*p_j) + (p_a*p_k)) + p_aj = x_kja * p_a + pp_k = p_k + p_j - (1.0_default - x_kja) * p_a + v_kja = 8.0_default * PI * CF * & + (2.0 / (1.0 - x_kja + u_j) - (1.0 + x_kja)) / x_kja end subroutine if_dipole @ %def if_dipole @ This function depends on a variable number of final state particles whose kinematics all get changed by the initial-initial dipole insertion. <>= public :: ii_dipole -<>= - pure subroutine ii_dipole (v_jab,v_j,p_in,p_out,flag_1or2) +<>= + pure module subroutine ii_dipole (v_jab, v_j, p_in, p_out, flag_1or2) type(vector4_t), dimension(:), intent(in) :: p_in type(vector4_t), dimension(size(p_in)-1), intent(out) :: p_out logical, intent(in) :: flag_1or2 - real(kind=default), intent(out) :: v_j - real(kind=default), intent(out) :: v_jab - type(vector4_t) :: p_a, p_b, p_j - type(vector4_t) :: k, kk - type(vector4_t) :: p_aj - real(kind=default) :: x_jab - integer :: i - !!! flag_1or2 decides whether this a 12 or 21 dipole - if (flag_1or2) then - p_a = p_in(1) - p_b = p_in(2) - else - p_b = p_in(1) - p_a = p_in(2) - end if - !!! We assume that the unresolved particle has always the last - !!! momentum - p_j = p_in(size(p_in)) - x_jab = ((p_a*p_b) - (p_a*p_j) - (p_b*p_j)) / (p_a*p_b) - v_j = (p_a*p_j) / (p_a * p_b) - p_aj = x_jab * p_a - k = p_a + p_b - p_j - kk = p_aj + p_b - do i = 3, size(p_in)-1 - p_out(i) = p_in(i) - 2.0*((k+kk)*p_in(i))/((k+kk)*(k+kk)) * (k+kk) + & - (2.0 * (k*p_in(i)) / (k*k)) * kk - end do - if (flag_1or2) then - p_out(1) = p_aj - p_out(2) = p_b - else - p_out(1) = p_b - p_out(2) = p_aj - end if - v_jab = 8.0_default * PI * CF * & - (2.0 / (1.0 - x_jab) - (1.0 + x_jab)) / x_jab + real(default), intent(out) :: v_j + real(default), intent(out) :: v_jab + end subroutine ii_dipole +<>= + pure module subroutine ii_dipole (v_jab, v_j, p_in, p_out, flag_1or2) + type(vector4_t), dimension(:), intent(in) :: p_in + type(vector4_t), dimension(size(p_in)-1), intent(out) :: p_out + logical, intent(in) :: flag_1or2 + real(default), intent(out) :: v_j + real(default), intent(out) :: v_jab + type(vector4_t) :: p_a, p_b, p_j + type(vector4_t) :: k, kk + type(vector4_t) :: p_aj + real(default) :: x_jab + integer :: i + !!! flag_1or2 decides whether this a 12 or 21 dipole + if (flag_1or2) then + p_a = p_in(1) + p_b = p_in(2) + else + p_b = p_in(1) + p_a = p_in(2) + end if + !!! We assume that the unresolved particle has always the last + !!! momentum + p_j = p_in(size(p_in)) + x_jab = ((p_a*p_b) - (p_a*p_j) - (p_b*p_j)) / (p_a*p_b) + v_j = (p_a*p_j) / (p_a * p_b) + p_aj = x_jab * p_a + k = p_a + p_b - p_j + kk = p_aj + p_b + do i = 3, size(p_in)-1 + p_out(i) = p_in(i) - 2.0*((k+kk)*p_in(i))/((k+kk)*(k+kk)) * (k+kk) + & + (2.0 * (k*p_in(i)) / (k*k)) * kk + end do + if (flag_1or2) then + p_out(1) = p_aj + p_out(2) = p_b + else + p_out(1) = p_b + p_out(2) = p_aj + end if + v_jab = 8.0_default * PI * CF * & + (2.0 / (1.0 - x_jab) - (1.0 + x_jab)) / x_jab end subroutine ii_dipole @ %def ii_dipole @ \subsection{Distributions for integrated dipoles and such} Note that the following formulae are only meaningful for $0 \leq x \leq 1$. The Dirac delta distribution, modified for Monte-Carlo sampling, centered at $x=1-\frac{\epsilon}{2}$: <>= public :: delta -<>= - elemental function delta (x,eps) result (z) - real(kind=default), intent(in) :: x, eps - real(kind=default) :: z +<>= + elemental module function delta (x,eps) result (z) + real(default), intent(in) :: x, eps + real(default) :: z + end function delta +<>= + elemental module function delta (x,eps) result (z) + real(default), intent(in) :: x, eps + real(default) :: z if (x > one - eps) then z = one / eps else z = 0 end if end function delta @ %def delta @ The $+$-distribution, $P_+(x) = \left( \frac{1}{1-x}\right)_+$, for the regularization of soft-collinear singularities. The constant part for the Monte-Carlo sampling is the integral over the splitting function divided by the weight for the WHIZARD numerical integration over the interval. <>= public :: plus_distr -<>= - elemental function plus_distr (x,eps) result (plusd) - real(kind=default), intent(in) :: x, eps - real(kind=default) :: plusd - if (x > one - eps) then - plusd = log(eps) / eps - else - plusd = one / (one - x) - end if +<>= + elemental module function plus_distr (x,eps) result (plusd) + real(default), intent(in) :: x, eps + real(default) :: plusd + end function plus_distr +<>= + elemental module function plus_distr (x,eps) result (plusd) + real(default), intent(in) :: x, eps + real(default) :: plusd + if (x > one - eps) then + plusd = log(eps) / eps + else + plusd = one / (one - x) + end if end function plus_distr @ %def plus_distr @ The splitting function in $D=4$ dimensions, regularized as $+$-distributions if necessary: \begin{align} P^{qq} (x) = P^{\bar q\bar q} (x) &= \; C_F \cdot \left( \frac{1 + x^2}{1-x} \right)_+ \\ P^{qg} (x) = P^{\bar q g} (x) &= \; C_F \cdot \frac{1 + (1-x)^2}{x}\\ P^{gq} (x) = P^{g \bar q} (x) &= \; T_R \cdot \left[ x^2 + (1-x)^2 \right] \\ P^{gg} (x) &= \; 2 C_A \biggl[ \left( \frac{1}{1-x} \right)_+ + \frac{1-x}{x} - 1 + x(1-x) \biggl] \notag{}\\ &\quad + \delta(1-x) \left( \frac{11}{6} C_A - \frac{2}{3} N_f T_R \right) \end{align} Since the number of flavors summed over in the gluon splitting function might depend on the physics case under consideration, it is implemented as an input variable. <>= public :: pqq -<>= - elemental function pqq (x,eps) result (pqqx) - real(kind=default), intent(in) :: x, eps - real(kind=default) :: pqqx - if (x > (1.0_default - eps)) then - pqqx = (eps - one) / two + two * log(eps) / eps - & - three * (eps - one) / eps / two - else - pqqx = (one + x**2) / (one - x) - end if - pqqx = CF * pqqx +<>= + elemental module function pqq (x,eps) result (pqqx) + real(default), intent(in) :: x, eps + real(default) :: pqqx + end function pqq +<>= + elemental module function pqq (x,eps) result (pqqx) + real(default), intent(in) :: x, eps + real(default) :: pqqx + if (x > (1.0_default - eps)) then + pqqx = (eps - one) / two + two * log(eps) / eps - & + three * (eps - one) / eps / two + else + pqqx = (one + x**2) / (one - x) + end if + pqqx = CF * pqqx end function pqq @ %def pqq @ <>= public :: pgq +<>= + elemental module function pgq (x) result (pgqx) + real(default), intent(in) :: x + real(default) :: pgqx + end function pgq <>= - elemental function pgq (x) result (pgqx) - real(kind=default), intent(in) :: x - real(kind=default) :: pgqx - pgqx = TR * (x**2 + (one - x)**2) + elemental module function pgq (x) result (pgqx) + real(default), intent(in) :: x + real(default) :: pgqx + pgqx = TR * (x**2 + (one - x)**2) end function pgq @ %def pgq @ <>= public :: pqg +<>= + elemental module function pqg (x) result (pqgx) + real(default), intent(in) :: x + real(default) :: pqgx + end function pqg <>= - elemental function pqg (x) result (pqgx) - real(kind=default), intent(in) :: x - real(kind=default) :: pqgx - pqgx = CF * (one + (one - x)**2) / x + elemental module function pqg (x) result (pqgx) + real(default), intent(in) :: x + real(default) :: pqgx + pqgx = CF * (one + (one - x)**2) / x end function pqg @ %def pqg @ <>= public :: pgg -<>= - elemental function pgg (x, nf, eps) result (pggx) - real(kind=default), intent(in) :: x, nf, eps - real(kind=default) :: pggx +<>= + elemental module function pgg (x, nf, eps) result (pggx) + real(default), intent(in) :: x, nf, eps + real(default) :: pggx + end function pgg +<>= + elemental module function pgg (x, nf, eps) result (pggx) + real(default), intent(in) :: x, nf, eps + real(default) :: pggx pggx = two * CA * ( plus_distr (x, eps) + (one-x)/x - one + & x*(one-x)) + delta (x, eps) * gamma_g(nf) end function pgg @ %def pgg @ For the $qq$ and $gg$ cases, there exist ``regularized'' versions of the splitting functions: \begin{align} P^{qq}_{\text{reg}} (x) &= - C_F \cdot (1 + x) \\ P^{gg}_{\text{reg}} (x) &= 2 C_A \left[ \frac{1-x}{x} - 1 + x(1-x) \right] \end{align} <>= public :: pqq_reg -<>= - elemental function pqq_reg (x) result (pqqregx) - real(kind=default), intent(in) :: x - real(kind=default) :: pqqregx +<>= + elemental module function pqq_reg (x) result (pqqregx) + real(default), intent(in) :: x + real(default) :: pqqregx + end function pqq_reg +<>= + elemental module function pqq_reg (x) result (pqqregx) + real(default), intent(in) :: x + real(default) :: pqqregx pqqregx = - CF * (one + x) end function pqq_reg @ %def pqq_reg @ <>= public :: pgg_reg -<>= - elemental function pgg_reg (x) result (pggregx) - real(kind=default), intent(in) :: x - real(kind=default) :: pggregx +<>= + elemental module function pgg_reg (x) result (pggregx) + real(default), intent(in) :: x + real(default) :: pggregx + end function pgg_reg +<>= + elemental module function pgg_reg (x) result (pggregx) + real(default), intent(in) :: x + real(default) :: pggregx pggregx = two * CA * ((one - x)/x - one + x*(one - x)) end function pgg_reg @ %def pgg_reg @ Here, we collect the expressions needed for integrated Catani-Seymour dipoles, and the so-called flavor kernels. We always distinguish between the ``ordinary'' Catani-Seymour version, and the one including a phase-space slicing parameter, $\alpha$. The standard flavor kernels $\overline{K}^{ab}$ are: \begin{align} \overline{K}^{qg} (x) = \overline{K}^{\bar q g} (x) & = \; P^{qg} (x) \log ((1-x)/x) + CF \times x \\ %%% \overline{K}^{gq} (x) = \overline{K}^{g \bar q} (x) & = \; P^{gq} (x) \log ((1-x)/x) + TR \times 2x(1-x) \\ %%% \overline{K}^{qq} &=\; C_F \biggl[ \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+ - (1+x) \log ((1-x)/x) + (1-x) \biggr] \notag{}\\ &\quad - (5 - \pi^2) \cdot C_F \cdot \delta(1-x) \\ %%% \overline{K}^{gg} &=\; 2 C_A \biggl[ \left( \frac{1}{1-x} \log \frac{1-x}{x} \right)_+ + \left( \frac{1-x}{x} - 1 + x(1-x) \right) \log((1-x)/x) \biggr] \notag{}\\ &\quad - \delta(1-x) \biggl[ \left( \frac{50}{9} - \pi^2 \right) C_A - \frac{16}{9} T_R N_f \biggr] \end{align} <>= public :: kbarqg +<>= + module function kbarqg (x) result (kbarqgx) + real(default), intent(in) :: x + real(default) :: kbarqgx + end function kbarqg <>= - function kbarqg (x) result (kbarqgx) - real(kind=default), intent(in) :: x - real(kind=default) :: kbarqgx + module function kbarqg (x) result (kbarqgx) + real(default), intent(in) :: x + real(default) :: kbarqgx kbarqgx = pqg(x) * log((one-x)/x) + CF * x end function kbarqg @ %def kbarqg @ <>= public :: kbargq +<>= + module function kbargq (x) result (kbargqx) + real(default), intent(in) :: x + real(default) :: kbargqx + end function kbargq <>= - function kbargq (x) result (kbargqx) - real(kind=default), intent(in) :: x - real(kind=default) :: kbargqx + module function kbargq (x) result (kbargqx) + real(default), intent(in) :: x + real(default) :: kbargqx kbargqx = pgq(x) * log((one-x)/x) + two * TR * x * (one - x) end function kbargq @ %def kbarqg @ <>= public :: kbarqq -<>= - function kbarqq (x,eps) result (kbarqqx) - real(kind=default), intent(in) :: x, eps - real(kind=default) :: kbarqqx +<>= + module function kbarqq (x,eps) result (kbarqqx) + real(default), intent(in) :: x, eps + real(default) :: kbarqqx + end function kbarqq +<>= + module function kbarqq (x,eps) result (kbarqqx) + real(default), intent(in) :: x, eps + real(default) :: kbarqqx kbarqqx = CF*(log_plus_distr(x,eps) - (one+x) * log((one-x)/x) + (one - & x) - (five - pi**2) * delta(x,eps)) end function kbarqq @ %def kbarqq @ <>= public :: kbargg -<>= - function kbargg (x,eps,nf) result (kbarggx) - real(kind=default), intent(in) :: x, eps, nf - real(kind=default) :: kbarggx +<>= + module function kbargg (x,eps,nf) result (kbarggx) + real(default), intent(in) :: x, eps, nf + real(default) :: kbarggx + end function kbargg +<>= + module function kbargg (x,eps,nf) result (kbarggx) + real(default), intent(in) :: x, eps, nf + real(default) :: kbarggx kbarggx = CA * (log_plus_distr(x,eps) + two * ((one-x)/x - one + & x*(one-x) * log((1-x)/x))) - delta(x,eps) * & ((50.0_default/9.0_default - pi**2) * CA - & 16.0_default/9.0_default * TR * nf) end function kbargg @ %def kbargg @ The $\tilde{K}$ are used when two identified hadrons participate: \begin{equation} \tilde{K}^{ab} (x) = P^{ab}_{\text{reg}} (x) \cdot \log (1-x) + \delta^{ab} \mathbf{T}_a^2 \biggl[ \left( \frac{2}{1-x} \log (1-x) \right)_+ - \frac{\pi^2}{3} \delta(1-x) \biggr] \end{equation} <>= public :: ktildeqq -<>= - function ktildeqq (x,eps) result (ktildeqqx) - real(kind=default), intent(in) :: x, eps - real(kind=default) :: ktildeqqx +<>= + module function ktildeqq (x,eps) result (ktildeqqx) + real(default), intent(in) :: x, eps + real(default) :: ktildeqqx + end function ktildeqq +<>= + module function ktildeqq (x,eps) result (ktildeqqx) + real(default), intent(in) :: x, eps + real(default) :: ktildeqqx ktildeqqx = pqq_reg (x) * log(one-x) + CF * ( - log2_plus_distr (x,eps) & - pi**2/three * delta(x,eps)) end function ktildeqq @ %def ktildeqq @ <>= public :: ktildeqg -<>= - function ktildeqg (x,eps) result (ktildeqgx) - real(kind=default), intent(in) :: x, eps - real(kind=default) :: ktildeqgx +<>= + module function ktildeqg (x,eps) result (ktildeqgx) + real(default), intent(in) :: x, eps + real(default) :: ktildeqgx + end function ktildeqg +<>= + module function ktildeqg (x,eps) result (ktildeqgx) + real(default), intent(in) :: x, eps + real(default) :: ktildeqgx ktildeqgx = pqg (x) * log(one-x) end function ktildeqg @ %def ktildeqg @ <>= public :: ktildegq -<>= - function ktildegq (x,eps) result (ktildegqx) - real(kind=default), intent(in) :: x, eps - real(kind=default) :: ktildegqx +<>= + module function ktildegq (x,eps) result (ktildegqx) + real(default), intent(in) :: x, eps + real(default) :: ktildegqx + end function ktildegq +<>= + module function ktildegq (x,eps) result (ktildegqx) + real(default), intent(in) :: x, eps + real(default) :: ktildegqx ktildegqx = pgq (x) * log(one-x) end function ktildegq @ %def ktildeqg @ <>= public :: ktildegg -<>= - function ktildegg (x,eps) result (ktildeggx) - real(kind=default), intent(in) :: x, eps - real(kind=default) :: ktildeggx +<>= + module function ktildegg (x,eps) result (ktildeggx) + real(default), intent(in) :: x, eps + real(default) :: ktildeggx + end function ktildegg +<>= + module function ktildegg (x,eps) result (ktildeggx) + real(default), intent(in) :: x, eps + real(default) :: ktildeggx ktildeggx = pgg_reg (x) * log(one-x) + CA * ( - & log2_plus_distr (x,eps) - pi**2/three * delta(x,eps)) end function ktildegg @ %def ktildegg @ The insertion operator might not be necessary for a GOLEM interface but is demanded by the Les Houches NLO accord. It is a three-dimensional array, where the index always gives the inverse power of the DREG expansion parameter, $\epsilon$. <>= public :: insert_q -<>= - pure function insert_q () - real(kind=default), dimension(0:2) :: insert_q - insert_q(0) = gamma_q + k_q - pi**2/three * CF - insert_q(1) = gamma_q - insert_q(2) = CF +<>= + pure module function insert_q () result (i_q) + real(default), dimension(0:2) :: i_q + end function insert_q +<>= + pure module function insert_q () result (i_q) + real(default), dimension(0:2) :: i_q + i_q(0) = gamma_q + k_q - pi**2/three * CF + i_q(1) = gamma_q + i_q(2) = CF end function insert_q @ %def insert_q @ <>= public :: insert_g +<>= + pure module function insert_g (nf) result (i_g) + real(default), intent(in) :: nf + real(default), dimension(0:2) :: i_g + end function insert_g <>= - pure function insert_g (nf) - real(kind=default), intent(in) :: nf - real(kind=default), dimension(0:2) :: insert_g - insert_g(0) = gamma_g (nf) + k_g (nf) - pi**2/three * CA - insert_g(1) = gamma_g (nf) - insert_g(2) = CA + pure module function insert_g (nf) result (i_g) + real(default), intent(in) :: nf + real(default), dimension(0:2) :: i_g + i_g(0) = gamma_g (nf) + k_g (nf) - pi**2/three * CA + i_g(1) = gamma_g (nf) + i_g(2) = CA end function insert_g @ %def insert_g @ For better convergence, one can exclude regions of phase space with a slicing parameter from the dipole subtraction procedure. First of all, the $K$ functions get modified: \begin{equation} K_i (\alpha) = K_i - \mathbf{T}_i^2 \log^2 \alpha + \gamma_i ( \alpha - 1 - \log\alpha) \end{equation} <>= public :: k_q_al, k_g_al -<>= - pure function k_q_al (alpha) - real(kind=default), intent(in) :: alpha - real(kind=default) :: k_q_al +<>= + pure module function k_q_al (alpha) + real(default), intent(in) :: alpha + real(default) :: k_q_al + end function k_q_al + pure module function k_g_al (alpha, nf) + real(default), intent(in) :: alpha, nf + real(default) :: k_g_al + end function k_g_al +<>= + pure module function k_q_al (alpha) + real(default), intent(in) :: alpha + real(default) :: k_q_al k_q_al = k_q - CF * (log(alpha))**2 + gamma_q * & (alpha - one - log(alpha)) end function k_q_al - pure function k_g_al (alpha, nf) - real(kind=default), intent(in) :: alpha, nf - real(kind=default) :: k_g_al + pure module function k_g_al (alpha, nf) + real(default), intent(in) :: alpha, nf + real(default) :: k_g_al k_g_al = k_g (nf) - CA * (log(alpha))**2 + gamma_g (nf) * & (alpha - one - log(alpha)) end function k_g_al @ %def k_q_al @ %def k_g_al @ The $+$-distribution, but with a phase-space slicing parameter, $\alpha$, $P_{1-\alpha}(x) = \left( \frac{1}{1-x} \right)_{1-x}$. Since we need the fatal error message here, this function cannot be elemental. <>= public :: plus_distr_al -<>= - function plus_distr_al (x,alpha,eps) result (plusd_al) - real(kind=default), intent(in) :: x, eps, alpha - real(kind=default) :: plusd_al - if ((one - alpha) >= (one - eps)) then - plusd_al = zero - call msg_fatal ('sm_physics, plus_distr_al: alpha and epsilon chosen wrongly') - elseif (x < (1.0_default - alpha)) then - plusd_al = 0 - else if (x > (1.0_default - eps)) then - plusd_al = log(eps/alpha)/eps - else - plusd_al = one/(one-x) - end if - end function plus_distr_al +<>= + module function plus_distr_al (x,alpha,eps) result (plusd_al) + real(default), intent(in) :: x, eps, alpha + real(default) :: plusd_al + end function plus_distr_al +<>= + module function plus_distr_al (x,alpha,eps) result (plusd_al) + real(default), intent(in) :: x, eps, alpha + real(default) :: plusd_al + if ((one - alpha) >= (one - eps)) then + plusd_al = zero + call msg_fatal ('sm_physics, plus_distr_al: alpha and epsilon chosen wrongly') + elseif (x < (1.0_default - alpha)) then + plusd_al = 0 + else if (x > (1.0_default - eps)) then + plusd_al = log(eps/alpha)/eps + else + plusd_al = one/(one-x) + end if + end function plus_distr_al @ %def plus_distr_al @ Introducing phase-space slicing parameters, these standard flavor kernels $\overline{K}^{ab}$ become: \begin{align} \overline{K}^{qg}_\alpha (x) = \overline{K}^{\bar q g}_\alpha (x) & = \; P^{qg} (x) \log (\alpha (1-x)/x) + C_F \times x \\ %%% \overline{K}^{gq}_\alpha (x) = \overline{K}^{g \bar q}_\alpha (x) & = \; P^{gq} (x) \log (\alpha (1-x)/x) + T_R \times 2x(1-x) \\ %%% \overline{K}^{qq}_\alpha &= C_F (1 - x) + P^{qq}_{\text{reg}} (x) \log \frac{\alpha(1-x)}{x} \notag{}\\ &\quad + C_F \delta (1 - x) \log^2 \alpha + C_F \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+ \notag{}\\ &\quad - \left( \gamma_q + K_q(\alpha) - \frac56 \pi^2 C_F \right) \cdot \delta(1-x) \; C_F \Bigl[ + \frac{2}{1-x} \log \left( \frac{\alpha (2-x)}{1+\alpha-x} \right) - \theta(1 - \alpha - x) \cdot \left( \frac{2}{1-x} \log \frac{2-x}{1-x} \right) \Bigr] \\ %%% \overline{K}^{gg}_\alpha &=\; P^{gg}_{\text{reg}} (x) \log \frac{\alpha(1-x)}{x} + C_A \delta (1 - x) \log^2 \alpha \notag{}\\ &\quad + C_A \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+ - \left( \gamma_g + K_g(\alpha) - \frac56 \pi^2 C_A \right) \cdot \delta(1-x) \; C_A \Bigl[ + \frac{2}{1-x} \log \left( \frac{\alpha (2-x)}{1+\alpha-x} \right) - \theta(1 - \alpha - x) \cdot \left( \frac{2}{1-x} \log \frac{2-x}{1-x} \right) \Bigr] \end{align} <>= public :: kbarqg_al -<>= - function kbarqg_al (x,alpha,eps) result (kbarqgx) - real(kind=default), intent(in) :: x, alpha, eps - real(kind=default) :: kbarqgx +<>= + module function kbarqg_al (x,alpha,eps) result (kbarqgx) + real(default), intent(in) :: x, alpha, eps + real(default) :: kbarqgx + end function kbarqg_al +<>= + module function kbarqg_al (x,alpha,eps) result (kbarqgx) + real(default), intent(in) :: x, alpha, eps + real(default) :: kbarqgx kbarqgx = pqg (x) * log(alpha*(one-x)/x) + CF * x end function kbarqg_al @ %def kbarqg_al @ <>= public :: kbargq_al -<>= - function kbargq_al (x,alpha,eps) result (kbargqx) - real(kind=default), intent(in) :: x, alpha, eps - real(kind=default) :: kbargqx +<>= + module function kbargq_al (x,alpha,eps) result (kbargqx) + real(default), intent(in) :: x, alpha, eps + real(default) :: kbargqx + end function kbargq_al +<>= + module function kbargq_al (x,alpha,eps) result (kbargqx) + real(default), intent(in) :: x, alpha, eps + real(default) :: kbargqx kbargqx = pgq (x) * log(alpha*(one-x)/x) + two * TR * x * (one-x) end function kbargq_al @ %def kbargq_al @ <>= public :: kbarqq_al -<>= - function kbarqq_al (x,alpha,eps) result (kbarqqx) - real(kind=default), intent(in) :: x, alpha, eps - real(kind=default) :: kbarqqx - kbarqqx = CF * (one - x) + pqq_reg(x) * log(alpha*(one-x)/x) & - + CF * log_plus_distr(x,eps) & - - (gamma_q + k_q_al(alpha) - CF * & - five/6.0_default * pi**2 - CF * (log(alpha))**2) * & - delta(x,eps) + & - CF * two/(one -x)*log(alpha*(two-x)/(one+alpha-x)) - if (x < (one-alpha)) then - kbarqqx = kbarqqx - CF * two/(one-x) * log((two-x)/(one-x)) - end if +<>= + module function kbarqq_al (x,alpha,eps) result (kbarqqx) + real(default), intent(in) :: x, alpha, eps + real(default) :: kbarqqx + end function kbarqq_al +<>= + module function kbarqq_al (x,alpha,eps) result (kbarqqx) + real(default), intent(in) :: x, alpha, eps + real(default) :: kbarqqx + kbarqqx = CF * (one - x) + pqq_reg(x) * log(alpha*(one-x)/x) & + + CF * log_plus_distr(x,eps) & + - (gamma_q + k_q_al(alpha) - CF * & + five/6.0_default * pi**2 - CF * (log(alpha))**2) * & + delta(x,eps) + & + CF * two/(one -x)*log(alpha*(two-x)/(one+alpha-x)) + if (x < (one-alpha)) then + kbarqqx = kbarqqx - CF * two/(one-x) * log((two-x)/(one-x)) + end if end function kbarqq_al @ %def kbarqq_al <>= public :: kbargg_al -<>= - function kbargg_al (x,alpha,eps,nf) result (kbarggx) - real(kind=default), intent(in) :: x, alpha, eps, nf - real(kind=default) :: kbarggx - kbarggx = pgg_reg(x) * log(alpha*(one-x)/x) & - + CA * log_plus_distr(x,eps) & - - (gamma_g(nf) + k_g_al(alpha,nf) - CA * & - five/6.0_default * pi**2 - CA * (log(alpha))**2) * & - delta(x,eps) + & - CA * two/(one -x)*log(alpha*(two-x)/(one+alpha-x)) - if (x < (one-alpha)) then - kbarggx = kbarggx - CA * two/(one-x) * log((two-x)/(one-x)) - end if +<>= + module function kbargg_al (x,alpha,eps,nf) result (kbarggx) + real(default), intent(in) :: x, alpha, eps, nf + real(default) :: kbarggx + end function kbargg_al +<>= + module function kbargg_al (x,alpha,eps,nf) result (kbarggx) + real(default), intent(in) :: x, alpha, eps, nf + real(default) :: kbarggx + kbarggx = pgg_reg(x) * log(alpha*(one-x)/x) & + + CA * log_plus_distr(x,eps) & + - (gamma_g(nf) + k_g_al(alpha,nf) - CA * & + five/6.0_default * pi**2 - CA * (log(alpha))**2) * & + delta(x,eps) + & + CA * two/(one -x)*log(alpha*(two-x)/(one+alpha-x)) + if (x < (one-alpha)) then + kbarggx = kbarggx - CA * two/(one-x) * log((two-x)/(one-x)) + end if end function kbargg_al @ %def kbargg_al @ The $\tilde{K}$ flavor kernels in the presence of a phase-space slicing parameter, are: \begin{equation} \tilde{K}^{ab} (x,\alpha) = P^{qq, \text{reg}} (x) \log\frac{1-x}{\alpha} + .......... \end{equation} <>= public :: ktildeqq_al -<>= - function ktildeqq_al (x,alpha,eps) result (ktildeqqx) - real(kind=default), intent(in) :: x, eps, alpha - real(kind=default) :: ktildeqqx +<>= + module function ktildeqq_al (x,alpha,eps) result (ktildeqqx) + real(default), intent(in) :: x, eps, alpha + real(default) :: ktildeqqx + end function ktildeqq_al +<>= + module function ktildeqq_al (x,alpha,eps) result (ktildeqqx) + real(default), intent(in) :: x, eps, alpha + real(default) :: ktildeqqx ktildeqqx = pqq_reg(x) * log((one-x)/alpha) + CF*( & - log2_plus_distr_al(x,alpha,eps) - Pi**2/three * delta(x,eps) & + (one+x**2)/(one-x) * log(min(one,(alpha/(one-x)))) & + two/(one-x) * log((one+alpha-x)/alpha)) if (x > (one-alpha)) then ktildeqqx = ktildeqqx - CF*two/(one-x)*log(two-x) end if end function ktildeqq_al @ %def ktildeqq_al @ This is a logarithmic $+$-distribution, $\left( \frac{\log((1-x)/x)}{1-x} \right)_+$. For the sampling, we need the integral over this function over the incomplete sampling interval $[0,1-\epsilon]$, which is $\log^2(x) + 2 Li_2(x) - \frac{\pi^2}{3}$. As this function is negative definite for $\epsilon > 0.1816$, we take a hard upper limit for that sampling parameter, irrespective of the fact what the user chooses. <>= public :: log_plus_distr -<>= - function log_plus_distr (x,eps) result (lpd) - real(kind=default), intent(in) :: x, eps - real(kind=default) :: lpd, eps2 +<>= + module function log_plus_distr (x,eps) result (lpd) + real(default), intent(in) :: x, eps + real(default) :: lpd, eps2 + end function log_plus_distr +<>= + module function log_plus_distr (x,eps) result (lpd) + real(default), intent(in) :: x, eps + real(default) :: lpd, eps2 eps2 = min (eps, 0.1816_default) if (x > (1.0_default - eps2)) then lpd = ((log(eps2))**2 + two*Li2(eps2) - pi**2/three)/eps2 else lpd = two*log((one-x)/x)/(one-x) end if end function log_plus_distr @ %def log_plus_distr @ Logarithmic $+$-distribution, $2 \left( \frac{\log(1/(1-x))}{1-x} \right)_+$. <>= public :: log2_plus_distr -<>= - function log2_plus_distr (x,eps) result (lpd) - real(kind=default), intent(in) :: x, eps - real(kind=default) :: lpd - if (x > (1.0_default - eps)) then - lpd = - (log(eps))**2/eps - else - lpd = two*log(one/(one-x))/(one-x) - end if +<>= + module function log2_plus_distr (x,eps) result (lpd) + real(default), intent(in) :: x, eps + real(default) :: lpd + end function log2_plus_distr +<>= + module function log2_plus_distr (x,eps) result (lpd) + real(default), intent(in) :: x, eps + real(default) :: lpd + if (x > (1.0_default - eps)) then + lpd = - (log(eps))**2/eps + else + lpd = two*log(one/(one-x))/(one-x) + end if end function log2_plus_distr @ %def log2_plus_distr @ Logarithmic $+$-distribution with phase-space slicing parameter, $2 \left( \frac{\log(1/(1-x))}{1-x} \right)_{1-\alpha}$. <>= public :: log2_plus_distr_al -<>= - function log2_plus_distr_al (x,alpha,eps) result (lpd_al) - real(kind=default), intent(in) :: x, eps, alpha - real(kind=default) :: lpd_al +<>= + module function log2_plus_distr_al (x,alpha,eps) result (lpd_al) + real(default), intent(in) :: x, eps, alpha + real(default) :: lpd_al + end function log2_plus_distr_al +<>= + module function log2_plus_distr_al (x,alpha,eps) result (lpd_al) + real(default), intent(in) :: x, eps, alpha + real(default) :: lpd_al if ((one - alpha) >= (one - eps)) then lpd_al = zero call msg_fatal ('alpha and epsilon chosen wrongly') elseif (x < (one - alpha)) then lpd_al = 0 elseif (x > (1.0_default - eps)) then lpd_al = - ((log(eps))**2 - (log(alpha))**2)/eps else lpd_al = two*log(one/(one-x))/(one-x) end if end function log2_plus_distr_al @ %def log2_plus_distr_al @ \subsection{Splitting Functions} @ Analogue to the regularized distributions of the last subsection, we give here the unregularized splitting functions, relevant for the parton shower algorithm. We can use this unregularized version since there will be a cut-off $\epsilon$ that ensures that $\{z,1-z\}>\epsilon(t)$. This cut-off seperates resolvable from unresolvable emissions. [[p_xxx]] are the kernels that are summed over helicity: <>= public :: p_qqg public :: p_gqq public :: p_ggg @ $q\to q g$ +<>= + elemental module function p_qqg (z) result (P) + real(default), intent(in) :: z + real(default) :: P + end function p_qqg <>= - elemental function p_qqg (z) result (P) + elemental module function p_qqg (z) result (P) real(default), intent(in) :: z real(default) :: P P = CF * (one + z**2) / (one - z) end function p_qqg @ $g\to q \bar{q}$ +<>= + elemental module function p_gqq (z) result (P) + real(default), intent(in) :: z + real(default) :: P + end function p_gqq <>= - elemental function p_gqq (z) result (P) + elemental module function p_gqq (z) result (P) real(default), intent(in) :: z real(default) :: P P = TR * (z**2 + (one - z)**2) end function p_gqq @ $g\to g g$ +<>= + elemental module function p_ggg (z) result (P) + real(default), intent(in) :: z + real(default) :: P + end function p_ggg <>= - elemental function p_ggg (z) result (P) + elemental module function p_ggg (z) result (P) real(default), intent(in) :: z real(default) :: P P = NC * ((one - z) / z + z / (one - z) + z * (one - z)) end function p_ggg @ %def p_qqg p_gqq p_ggg @ Analytically integrated splitting kernels: <>= public :: integral_over_p_qqg public :: integral_over_p_gqq public :: integral_over_p_ggg +<>= + pure module function integral_over_p_qqg (zmin, zmax) result (integral) + real(default), intent(in) :: zmin, zmax + real(default) :: integral + end function integral_over_p_qqg + pure module function integral_over_p_gqq (zmin, zmax) result (integral) + real(default), intent(in) :: zmin, zmax + real(default) :: integral + end function integral_over_p_gqq + pure module function integral_over_p_ggg (zmin, zmax) result (integral) + real(default), intent(in) :: zmin, zmax + real(default) :: integral + end function integral_over_p_ggg <>= - pure function integral_over_p_qqg (zmin, zmax) result (integral) + pure module function integral_over_p_qqg (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral integral = (two / three) * (- zmax**2 + zmin**2 - & two * (zmax - zmin) + four * log((one - zmin) / (one - zmax))) end function integral_over_p_qqg - pure function integral_over_p_gqq (zmin, zmax) result (integral) + pure module function integral_over_p_gqq (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral integral = 0.5_default * ((two / three) * & (zmax**3 - zmin**3) - (zmax**2 - zmin**2) + (zmax - zmin)) end function integral_over_p_gqq - pure function integral_over_p_ggg (zmin, zmax) result (integral) + pure module function integral_over_p_ggg (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral integral = three * ((log(zmax) - two * zmax - & log(one - zmax) + zmax**2 / two - zmax**3 / three) - & (log(zmin) - zmin - zmin - log(one - zmin) + zmin**2 & / two - zmin**3 / three) ) end function integral_over_p_ggg @ %def integral_over_p_gqq integral_over_p_ggg integral_over_p_qqg @ We can also use (massless) helicity dependent splitting functions: <>= public :: p_qqg_pol @ $q_a\to q_b g_c$, the helicity of the quark is not changed by gluon emission and the gluon is preferably polarized in the branching plane ($l_c=1$): +<>= + elemental module function p_qqg_pol (z, l_a, l_b, l_c) result (P) + real(default), intent(in) :: z + integer, intent(in) :: l_a, l_b, l_c + real(default) :: P + end function p_qqg_pol <>= - elemental function p_qqg_pol (z, l_a, l_b, l_c) result (P) + elemental module function p_qqg_pol (z, l_a, l_b, l_c) result (P) real(default), intent(in) :: z integer, intent(in) :: l_a, l_b, l_c real(default) :: P if (l_a /= l_b) then P = zero return end if if (l_c == -1) then P = one - z else P = (one + z)**2 / (one - z) end if P = P * CF end function p_qqg_pol @ \subsubsection{Mellin transforms of splitting functions} As Mellin transforms necessarily live in the complex plane, all functions are defined as complex functions: @ Splitting function $P_{qq}(N)$: <>= public :: pqqm +<>= + module function pqqm (n, c_f) result (pqq_m) + integer, intent(in) :: n + real(default), intent(in) :: c_f + complex(default) :: pqq_m + end function pqqm <>= - function pqqm (n, c_f) result (pqq_m) + module function pqqm (n, c_f) result (pqq_m) integer, intent(in) :: n real(default), intent(in) :: c_f complex(default) :: pqq_m pqq_m = three - four * (eulerc + & psic(cmplx(N+1,zero,kind=default))) + two/N/(N+1) end function pqqm @ %def pqqm @ \subsection{Top width} In order to produce sensible results, the widths have to be recomputed for each parameter and order. We start with the LO-expression for the top width given by the decay $t\,\to\,W^+,b$, cf. [[doi:10.1016/0550-3213(91)90530-B]]:\\ The analytic formula given there is \begin{equation*} \Gamma = \frac{G_F m_t^2}{16\sqrt{2}\pi} \left[\mathcal{F}_0(\varepsilon, \xi^{-1/2}) - \frac{2\alpha_s}{3\pi} \mathcal{F}_1 (\varepsilon, \xi^{-1/2})\right], \end{equation*} with \begin{align*} \mathcal{F}_0 &= \frac{\sqrt{\lambda}}{2} f_0, \\ f_0 &= 4\left[(1-\varepsilon^2)^2 + w^2(1+\varepsilon^2) - 2w^4\right], \\ \lambda = 1 + w^4 + \varepsilon^4 - 2(w^2 + \varepsilon^2 + w^2\varepsilon^2). \end{align*} Defining \begin{equation*} u_q = \frac{1 + \varepsilon^2 - w^2 - \lambda^{1/2}}{1 + \varepsilon^2 - w^2 + \lambda^{1/2}} \end{equation*} and \begin{equation*} u_w = \frac{1 - \varepsilon^2 + w^2 - \lambda^{1/2}}{1 - \varepsilon^2 + w^2 + \lambda^{1/2}} \end{equation*} the factor $\mathcal{F}_1$ can be expressed as \begin{align*} \mathcal{F}_1 = \frac{1}{2}f_0(1+\varepsilon^2-w^2) & \left[\pi^2 + 2Li_2(u_w) - 2Li_2(1-u_w) - 4Li_2(u_q) \right. \\ & -4Li_2(u_q u_w) + \log\left(\frac{1-u_q}{w^2}\right)\log(1-u_q) - \log^2(1-u_q u_w) \\ & \left.+\frac{1}{4}\log^2\left(\frac{w^2}{u_w}\right) - \log(u_w) \log\left[\frac{(1-u_q u_w)^2}{1-u_q}\right] -2\log(u_q)\log\left[(1-u_q)(1-u_q u_w)\right]\right] \\ & -\sqrt{\lambda}f_0(2\log(w) + 3\log(\varepsilon) - 2\log{\lambda}) \\ & +4(1-\varepsilon^2)\left[(1-\varepsilon^2)^2 + w^2(1+\varepsilon^2) - 4w^4\right]\log(u_w) \\ & \left[(3 - \varepsilon^2 + 11\varepsilon^4 - \varepsilon^6) + w^2(6 - 12\varepsilon^2 +2\varepsilon^4) - w^4(21 + 5\varepsilon^2) + 12w^6\right] \log(u_q) \\ & 6\sqrt{\lambda} (1-\varepsilon^2) (1 + \varepsilon^2 - w^2) \log(\varepsilon) + \sqrt{\lambda}\left[-5 + 22\varepsilon^2 - 5\varepsilon^4 - 9w^2(1+\varepsilon^2) + 6w^4\right]. \end{align*} @ <>= public :: top_width_sm_lo +<>= + elemental module function top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) & + result (gamma) + real(default) :: gamma + real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb + end function top_width_sm_lo <>= - elemental function top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) & + elemental module function top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) & result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb real(default) :: kappa kappa = sqrt ((mtop**2 - (mw + mb)**2) * (mtop**2 - (mw - mb)**2)) gamma = alpha / four * mtop / (two * sinthw**2) * & vtb**2 * kappa / mtop**2 * & ((mtop**2 + mb**2) / (two * mtop**2) + & (mtop**2 - mb**2)**2 / (two * mtop**2 * mw**2) - & mw**2 / mtop**2) end function top_width_sm_lo @ %def top_width_sm_lo @ <>= public :: g_mu_from_alpha +<>= + elemental module function g_mu_from_alpha (alpha, mw, sinthw) result (g_mu) + real(default) :: g_mu + real(default), intent(in) :: alpha, mw, sinthw + end function g_mu_from_alpha <>= - elemental function g_mu_from_alpha (alpha, mw, sinthw) result (g_mu) + elemental module function g_mu_from_alpha (alpha, mw, sinthw) result (g_mu) real(default) :: g_mu real(default), intent(in) :: alpha, mw, sinthw g_mu = pi * alpha / sqrt(two) / mw**2 / sinthw**2 end function g_mu_from_alpha @ %def g_mu_from_alpha @ <>= public :: alpha_from_g_mu +<>= + elemental module function alpha_from_g_mu (g_mu, mw, sinthw) result (alpha) + real(default) :: alpha + real(default), intent(in) :: g_mu, mw, sinthw + end function alpha_from_g_mu <>= - elemental function alpha_from_g_mu (g_mu, mw, sinthw) result (alpha) + elemental module function alpha_from_g_mu (g_mu, mw, sinthw) result (alpha) real(default) :: alpha real(default), intent(in) :: g_mu, mw, sinthw alpha = g_mu * sqrt(two) / pi * mw**2 * sinthw**2 end function alpha_from_g_mu @ %def alpha_from_g_mu @ Cf. (3.3)-(3.7) in [[1207.5018]]. <>= public :: top_width_sm_qcd_nlo_massless_b +<>= + elemental module function top_width_sm_qcd_nlo_massless_b & + (alpha, sinthw, vtb, mtop, mw, alphas) result (gamma) + real(default) :: gamma + real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, alphas + end function top_width_sm_qcd_nlo_massless_b <>= - elemental function top_width_sm_qcd_nlo_massless_b & + elemental module function top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, alphas real(default) :: prefac, g_mu, w2 g_mu = g_mu_from_alpha (alpha, mw, sinthw) prefac = g_mu * mtop**3 * vtb**2 / (16 * sqrt(two) * pi) w2 = mw**2 / mtop**2 gamma = prefac * (f0 (w2) - (two * alphas) / (3 * Pi) * f1 (w2)) end function top_width_sm_qcd_nlo_massless_b @ %def top_width_sm_qcd_nlo_massless_b @ <>= public :: f0 +<>= + elemental module function f0 (w2) result (f) + real(default) :: f + real(default), intent(in) :: w2 + end function f0 <>= - elemental function f0 (w2) result (f) + elemental module function f0 (w2) result (f) real(default) :: f real(default), intent(in) :: w2 f = two * (one - w2)**2 * (1 + 2 * w2) end function f0 @ %def f0 @ <>= public :: f1 +<>= + elemental module function f1 (w2) result (f) + real(default) :: f + real(default), intent(in) :: w2 + end function f1 <>= - elemental function f1 (w2) result (f) + elemental module function f1 (w2) result (f) real(default) :: f real(default), intent(in) :: w2 f = f0 (w2) * (pi**2 + two * Li2 (w2) - two * Li2 (one - w2)) & + four * w2 * (one - w2 - two * w2**2) * log (w2) & + two * (one - w2)**2 * (five + four * w2) * log (one - w2) & - (one - w2) * (five + 9 * w2 - 6 * w2**2) end function f1 @ %def f1 @ Basically, the same as above but with $m_b$ dependence, cf. Jezabek / Kuehn 1989. <>= public :: top_width_sm_qcd_nlo_jk +<>= + elemental module function top_width_sm_qcd_nlo_jk & + (alpha, sinthw, vtb, mtop, mw, mb, alphas) result (gamma) + real(default) :: gamma + real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alphas + end function top_width_sm_qcd_nlo_jk <>= - elemental function top_width_sm_qcd_nlo_jk & + elemental module function top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alphas real(default) :: prefac, g_mu, eps2, i_xi g_mu = g_mu_from_alpha (alpha, mw, sinthw) prefac = g_mu * mtop**3 * vtb**2 / (16 * sqrt(two) * pi) eps2 = (mb / mtop)**2 i_xi = (mw / mtop)**2 gamma = prefac * (ff0 (eps2, i_xi) - & (two * alphas) / (3 * Pi) * ff1 (eps2, i_xi)) end function top_width_sm_qcd_nlo_jk @ %def top_width_sm_qcd_nlo_jk @ Same as above, $m_b > 0$, with the slightly different implementation (2.6) of arXiv:1204.1513v1 by Campbell and Ellis. <>= public :: top_width_sm_qcd_nlo_ce +<>= + elemental module function top_width_sm_qcd_nlo_ce & + (alpha, sinthw, vtb, mtop, mw, mb, alpha_s) result (gamma) + real(default) :: gamma + real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alpha_s + end function top_width_sm_qcd_nlo_ce <>= - elemental function top_width_sm_qcd_nlo_ce & + elemental module function top_width_sm_qcd_nlo_ce & (alpha, sinthw, vtb, mtop, mw, mb, alpha_s) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alpha_s real(default) :: pm, pp, p0, p3 real(default) :: yw, yp real(default) :: W0, Wp, Wm, w2 real(default) :: beta2 real(default) :: f real(default) :: g_mu, gamma0 beta2 = (mb / mtop)**2 w2 = (mw / mtop)**2 p0 = (one - w2 + beta2) / two p3 = sqrt (lambda (one, w2, beta2)) / two pp = p0 + p3 pm = p0 - p3 W0 = (one + w2 - beta2) / two Wp = W0 + p3 Wm = W0 - p3 yp = log (pp / pm) / two yw = log (Wp / Wm) / two f = (one - beta2)**2 + w2 * (one + beta2) - two * w2**2 g_mu = g_mu_from_alpha (alpha, mw, sinthw) gamma0 = g_mu * mtop**3 * vtb**2 / (8 * pi * sqrt(two)) gamma = gamma0 * alpha_s / twopi * CF * & (8 * f * p0 * (Li2(one - pm) - Li2(one - pp) - two * Li2(one - pm / pp) & + yp * log((four * p3**2) / (pp**2 * Wp)) + yw * log (pp)) & + four * (one - beta2) * ((one - beta2)**2 + w2 * (one + beta2) - four * w2**2) * yw & + (3 - beta2 + 11 * beta2**2 - beta2**3 + w2 * (6 - 12 * beta2 + two * beta2**2) & - w2**2 * (21 + 5 * beta2) + 12 * w2**3) * yp & + 8 * f * p3 * log (sqrt(w2) / (four * p3**2)) & + 6 * (one - four * beta2 + 3 * beta2**2 + w2 * (3 + beta2) - four * w2**2) * p3 * log(sqrt(beta2)) & + (5 - 22 * beta2 + 5 * beta2**2 + 9 * w2 * (one + beta2) - 6 * w2**2) * p3) end function top_width_sm_qcd_nlo_ce @ %def top_width_sm_qcd_nlo_ce @ <>= public :: ff0 +<>= + elemental module function ff0 (eps2, w2) result (f) + real(default) :: f + real(default), intent(in) :: eps2, w2 + end function ff0 <>= - elemental function ff0 (eps2, w2) result (f) + elemental module function ff0 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 f = one / two * sqrt(ff_lambda (eps2, w2)) * ff_f0 (eps2, w2) end function ff0 @ %def ff0 @ <>= public :: ff_f0 +<>= + elemental module function ff_f0 (eps2, w2) result (f) + real(default) :: f + real(default), intent(in) :: eps2, w2 + end function ff_f0 <>= - elemental function ff_f0 (eps2, w2) result (f) + elemental module function ff_f0 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 f = four * ((1 - eps2)**2 + w2 * (1 + eps2) - 2 * w2**2) end function ff_f0 @ %def ff_f0 @ <>= public :: ff_lambda +<>= + elemental module function ff_lambda (eps2, w2) result (l) + real(default) :: l + real(default), intent(in) :: eps2, w2 + end function ff_lambda <>= - elemental function ff_lambda (eps2, w2) result (l) + elemental module function ff_lambda (eps2, w2) result (l) real(default) :: l real(default), intent(in) :: eps2, w2 l = one + w2**2 + eps2**2 - two * (w2 + eps2 + w2 * eps2) end function ff_lambda @ %def ff_lambda @ <>= public :: ff1 +<>= + elemental module function ff1 (eps2, w2) result (f) + real(default) :: f + real(default), intent(in) :: eps2, w2 + end function ff1 <>= - elemental function ff1 (eps2, w2) result (f) + elemental module function ff1 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 real(default) :: uq, uw, sq_lam, fff sq_lam = sqrt (ff_lambda (eps2, w2)) fff = ff_f0 (eps2, w2) uw = (one - eps2 + w2 - sq_lam) / & (one - eps2 + w2 + sq_lam) uq = (one + eps2 - w2 - sq_lam) / & (one + eps2 - w2 + sq_lam) f = one / two * fff * (one + eps2 - w2) * & (pi**2 + two * Li2 (uw) - two * Li2 (one - uw) - four * Li2 (uq) & - four * Li2 (uq * uw) + log ((one - uq) / w2) * log (one - uq) & - log (one - uq * uw)**2 + one / four * log (w2 / uw)**2 & - log (uw) * log ((one - uq * uw)**2 / (one - uq)) & - two * log (uq) * log ((one - uq) * (one - uq * uw))) & - sq_lam * fff * (two * log (sqrt (w2)) & + three * log (sqrt (eps2)) - two * log (sq_lam**2)) & + four * (one - eps2) * ((one - eps2)**2 + w2 * (one + eps2) & - four * w2**2) * log (uw) & + (three - eps2 + 11 * eps2**2 - eps2**3 + w2 * & (6 - 12 * eps2 + 2 * eps2**2) - w2**2 * (21 + five * eps2) & + 12 * w2**3) * log (uq) & + 6 * sq_lam * (one - eps2) * & (one + eps2 - w2) * log (sqrt (eps2)) & + sq_lam * (- five + 22 * eps2 - five * eps2**2 - 9 * w2 * & (one + eps2) + 6 * w2**2) end function ff1 @ %def ff1 @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sm_physics_ut.f90]]>>= <> module sm_physics_ut use unit_tests use sm_physics_uti <> <> contains <> end module sm_physics_ut @ %def sm_physics_ut @ <<[[sm_physics_uti.f90]]>>= <> module sm_physics_uti <> use numeric_utils use format_defs, only: FMT_15 use constants use sm_physics <> <> contains <> end module sm_physics_uti @ %def sm_physics_ut @ API: driver for the unit tests below. <>= public :: sm_physics_test <>= subroutine sm_physics_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sm_physics_test @ %def sm_physics_test @ \subsubsection{Splitting functions} <>= call test (sm_physics_1, "sm_physics_1", & "Splitting functions", & u, results) <>= public :: sm_physics_1 <>= subroutine sm_physics_1 (u) integer, intent(in) :: u real(default) :: z = 0.75_default write (u, "(A)") "* Test output: sm_physics_1" write (u, "(A)") "* Purpose: check analytic properties" write (u, "(A)") write (u, "(A)") "* Splitting functions:" write (u, "(A)") call assert (u, vanishes (p_qqg_pol (z, +1, -1, +1)), "+-+") call assert (u, vanishes (p_qqg_pol (z, +1, -1, -1)), "+--") call assert (u, vanishes (p_qqg_pol (z, -1, +1, +1)), "-++") call assert (u, vanishes (p_qqg_pol (z, -1, +1, -1)), "-+-") !call assert (u, nearly_equal ( & !p_qqg_pol (z, +1, +1, -1) + p_qqg_pol (z, +1, +1, +1), & !p_qqg (z)), "pol sum") write (u, "(A)") write (u, "(A)") "* Test output end: sm_physics_1" end subroutine sm_physics_1 @ %def sm_physics_1 @ \subsubsection{Top width} <>= call test(sm_physics_2, "sm_physics_2", & "Top width", u, results) <>= public :: sm_physics_2 <>= subroutine sm_physics_2 (u) integer, intent(in) :: u real(default) :: mtop, mw, mz, mb, g_mu, sinthw, alpha, vtb, gamma0 real(default) :: w2, alphas, alphas_mz, gamma1 write (u, "(A)") "* Test output: sm_physics_2" write (u, "(A)") "* Purpose: Check different top width computations" write (u, "(A)") write (u, "(A)") "* Values from [[1207.5018]] (massless b)" mtop = 172.0 mw = 80.399 mz = 91.1876 mb = zero mb = 0.00001 g_mu = 1.16637E-5 sinthw = sqrt(one - mw**2 / mz**2) alpha = alpha_from_g_mu (g_mu, mw, sinthw) vtb = one w2 = mw**2 / mtop**2 write (u, "(A)") "* Check Li2 implementation" call assert_equal (u, Li2(w2), 0.2317566263959552_default, & "Li2(w2)", rel_smallness=1.0E-6_default) call assert_equal (u, Li2(one - w2), 1.038200378935867_default, & "Li2(one - w2)", rel_smallness=1.0E-6_default) write (u, "(A)") "* Check LO Width" gamma0 = top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) call assert_equal (u, gamma0, 1.4655_default, & "top_width_sm_lo", rel_smallness=1.0E-5_default) alphas = zero gamma0 = top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) call assert_equal (u, gamma0, 1.4655_default, & "top_width_sm_qcd_nlo_massless_b", rel_smallness=1.0E-5_default) gamma0 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) call assert_equal (u, gamma0, 1.4655_default, & "top_width_sm_qcd_nlo", rel_smallness=1.0E-5_default) write (u, "(A)") "* Check NLO Width" alphas_mz = 0.1202 ! MSTW2008 NLO fit alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default) gamma1 = top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) call assert_equal (u, gamma1, 1.3376_default, rel_smallness=1.0E-4_default) gamma1 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) ! It would be nice to get one more significant digit but the ! expression is numerically rather unstable for mb -> 0 call assert_equal (u, gamma1, 1.3376_default, rel_smallness=1.0E-3_default) write (u, "(A)") "* Values from threshold validation (massive b)" alpha = one / 125.924 ! ee = 0.315901 ! cw = 0.881903 ! v = 240.024 mtop = 172.0 ! This is the value for M1S !!! mb = 4.2 sinthw = 0.47143 mz = 91.188 mw = 80.419 call assert_equal (u, sqrt(one - mw**2 / mz**2), sinthw, & "sinthw", rel_smallness=1.0E-6_default) write (u, "(A)") "* Check LO Width" gamma0 = top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) call assert_equal (u, gamma0, 1.5386446_default, & "gamma0", rel_smallness=1.0E-7_default) alphas = zero gamma0 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) call assert_equal (u, gamma0, 1.5386446_default, & "gamma0", rel_smallness=1.0E-7_default) write (u, "(A)") "* Check NLO Width" alphas_mz = 0.118 !(Z pole, NLL running to mu_h) alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default) write (u, "(A," // FMT_15 // ")") "* alphas = ", alphas gamma1 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) write (u, "(A," // FMT_15 // ")") "* Gamma1 = ", gamma1 mb = zero gamma1 = top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default) write (u, "(A," // FMT_15 // ")") "* Gamma1(mb=0) = ", gamma1 write (u, "(A)") write (u, "(A)") "* Test output end: sm_physics_2" end subroutine sm_physics_2 @ %def sm_physics_2 @ \subsubsection{Special functions} <>= call test (sm_physics_3, "sm_physics_3", & "Special functions", & u, results) <>= public :: sm_physics_3 <>= subroutine sm_physics_3 (u) integer, intent(in) :: u complex(default) :: z1 = (0.75_default, 1.25_default) complex(default) :: z2 = (1.33_default, 11.25_default) complex(default) :: psiz write (u, "(A)") "* Test output: sm_physics_3" write (u, "(A)") "* Purpose: check special functions" write (u, "(A)") write (u, "(A)") "* Complex digamma function:" write (u, "(A)") psiz = psic (z1) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F7.5,',',F7.5,')')") " psi(z1) = ", & real(psiz), aimag(psiz) psiz = psic (z2) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F7.5,',',F7.5,')')") " psi(z2) = ", & real(psiz), aimag(psiz) write (u, "(A)") write (u, "(A)") "* Complex polygamma function:" write (u, "(A)") psiz = psim (z1,1) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,1) = ", & real(psiz), aimag(psiz) psiz = psim (z2,1) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,1) = ", & real(psiz), aimag(psiz) write (u, "(A)") psiz = psim (z1,2) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,2) = ", & real(psiz), aimag(psiz) psiz = psim (z2,2) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,2) = ", & real(psiz), aimag(psiz) write (u, "(A)") psiz = psim (z1,3) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,3) = ", & real(psiz), aimag(psiz) psiz = psim (z2,3) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,3) = ", & real(psiz), aimag(psiz) write (u, "(A)") psiz = psim (z1,4) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,4) = ", & real(psiz), aimag(psiz) psiz = psim (z2,4) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,4) = ", & real(psiz), aimag(psiz) write (u, "(A)") psiz = psim (z1,5) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,5) = ", & real(psiz), aimag(psiz) psiz = psim (z2,5) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,5) = ", & real(psiz), aimag(psiz) write (u, "(A)") write (u, "(A)") "* Generalized Nielsen polylogarithm:" write (u, "(A)") write (u, "(1x,A,F8.5)") " S(1,1,0) = ", & nielsen(1,1,0._default) write (u, "(1x,A,F8.5)") " S(1,1,-1) = ", & nielsen(1,1,-1._default) write (u, "(1x,A,F8.5)") " S(1,2,-1) = ", & nielsen(1,2,-1._default) write (u, "(1x,A,F8.5)") " S(2,1,-1) = ", & nielsen(2,1,-1._default) write (u, "(1x,A,F8.5)") " S(1,3,-1) = ", & nielsen(1,3,-1._default) write (u, "(1x,A,F8.5)") " S(2,2,-1) = ", & nielsen(2,2,-1._default) write (u, "(1x,A,F8.5)") " S(3,1,-1) = ", & nielsen(3,1,-1._default) write (u, "(1x,A,F8.5)") " S(1,4,-1) = ", & nielsen(1,4,-1._default) write (u, "(1x,A,F8.5)") " S(2,3,-1) = ", & nielsen(2,3,-1._default) write (u, "(1x,A,F8.5)") " S(3,2,-1) = ", & nielsen(3,2,-1._default) write (u, "(1x,A,F8.5)") " S(4,1,-1) = ", & nielsen(4,1,-1._default) write (u, "(1x,A,F8.5)") " S(1,1,0.2) = ", & nielsen(1,1,0.2_default) write (u, "(1x,A,F8.5)") " S(1,2,0.2) = ", & nielsen(1,2,0.2_default) write (u, "(1x,A,F8.5)") " S(2,1,0.2) = ", & nielsen(2,1,0.2_default) write (u, "(1x,A,F8.5)") " S(1,3,0.2) = ", & nielsen(1,3,0.2_default) write (u, "(1x,A,F8.5)") " S(2,2,0.2) = ", & nielsen(2,2,0.2_default) write (u, "(1x,A,F8.5)") " S(3,1,0.2) = ", & nielsen(3,1,0.2_default) write (u, "(1x,A,F8.5)") " S(1,4,0.2) = ", & nielsen(1,4,0.2_default) write (u, "(1x,A,F8.5)") " S(2,3,0.2) = ", & nielsen(2,3,0.2_default) write (u, "(1x,A,F8.5)") " S(3,2,0.2) = ", & nielsen(3,2,0.2_default) write (u, "(1x,A,F8.5)") " S(4,1,0.2) = ", & nielsen(4,1,0.2_default) write (u, "(1x,A,F8.5)") " S(1,1,1) = ", & nielsen(1,1,1._default) write (u, "(1x,A,F8.5)") " S(1,2,1) = ", & nielsen(1,2,1._default) write (u, "(1x,A,F8.5)") " S(2,1,1) = ", & nielsen(2,1,1._default) write (u, "(1x,A,F8.5)") " S(1,3,1) = ", & nielsen(1,3,1._default) write (u, "(1x,A,F8.5)") " S(2,2,1) = ", & nielsen(2,2,1._default) write (u, "(1x,A,F8.5)") " S(3,1,1) = ", & nielsen(3,1,1._default) write (u, "(1x,A,F8.5)") " S(1,4,1) = ", & nielsen(1,4,1._default) write (u, "(1x,A,F8.5)") " S(2,3,1) = ", & nielsen(2,3,1._default) write (u, "(1x,A,F8.5)") " S(3,2,1) = ", & nielsen(3,2,1._default) write (u, "(1x,A,F8.5)") " S(4,1,1) = ", & nielsen(4,1,1._default) write (u, "(1x,A,F8.5)") " S(1,1,0.75) = ", & nielsen(1,1,0.75_default) write (u, "(1x,A,F8.5)") " S(1,3,0.75) = ", & nielsen(1,3,0.75_default) write (u, "(1x,A,F8.5)") " S(1,4,0.75) = ", & nielsen(1,4,0.75_default) write (u, "(1x,A,F8.5)") " S(2,2,0.75) = ", & nielsen(2,2,0.75_default) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " S(1,1,2) = ", & real(cnielsen(1,1,3._default)), & aimag(cnielsen(1,1,3._default)) write (u, "(A)") write (u, "(A)") "* Dilog, trilog, polylog:" write (u, "(A)") write (u, "(1x,A,F8.5)") " Li2(0.66) = ", & dilog(0.66_default) write (u, "(1x,A,F8.5)") " Li3(0.66) = ", & trilog(0.66_default) write (u, "(1x,A,F8.5)") " Poly(4,0.66) = ", & polylog(4,0.66_default) write (u, "(A)") write (u, "(A)") "* Test output end: sm_physics_3" end subroutine sm_physics_3 @ %def sm_physics_3 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{QCD Coupling} We provide various distinct implementations of the QCD coupling. In this module, we define an abstract data type and three implementations: fixed, running with $\alpha_s(M_Z)$ as input, and running with $\Lambda_{\text{QCD}}$ as input. We use the functions defined above in the module [[sm_physics]] but provide a common interface. Later modules may define additional implementations. <<[[sm_qcd.f90]]>>= <> module sm_qcd <> - use io_units - use format_defs, only: FMT_12 - use numeric_utils - use diagnostics - use md5 use physics_defs - use sm_physics <> <> <> <> + interface +<> + end interface + +end module sm_qcd +@ %def sm_qcd +@ +<<[[sm_qcd_sub.f90]]>>= +<> + +submodule (sm_qcd) sm_qcd_s + + use io_units + use format_defs, only: FMT_12 + use numeric_utils + use diagnostics + use md5 + use sm_physics + + implicit none + contains <> -end module sm_qcd -@ %def sm_qcd +end submodule sm_qcd_s + +@ %def sm_qcd_s @ \subsection{Coupling: Abstract Data Type} This is the abstract version of the QCD coupling implementation. <>= public :: alpha_qcd_t <>= type, abstract :: alpha_qcd_t contains <> end type alpha_qcd_t @ %def alpha_qcd_t @ There must be an output routine. <>= procedure (alpha_qcd_write), deferred :: write <>= abstract interface subroutine alpha_qcd_write (object, unit) import class(alpha_qcd_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qcd_write end interface @ %def alpha_qcd_write @ This method computes the running coupling, given a certain scale. All parameters (reference value, order of the approximation, etc.) must be set before calling this. <>= procedure (alpha_qcd_get), deferred :: get <>= abstract interface function alpha_qcd_get (alpha_qcd, scale) result (alpha) import class(alpha_qcd_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha end function alpha_qcd_get end interface @ %def alpha_qcd_get @ \subsection{Fixed Coupling} In this version, the $\alpha_s$ value is fixed, the [[scale]] argument of the [[get]] method is ignored. There is only one parameter, the value. By default, this is the value at $M_Z$. <>= public :: alpha_qcd_fixed_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_fixed_t real(default) :: val = ALPHA_QCD_MZ_REF contains <> end type alpha_qcd_fixed_t @ %def alpha_qcd_fixed_t @ Output. <>= procedure :: write => alpha_qcd_fixed_write +<>= + module subroutine alpha_qcd_fixed_write (object, unit) + class(alpha_qcd_fixed_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine alpha_qcd_fixed_write <>= - subroutine alpha_qcd_fixed_write (object, unit) + module subroutine alpha_qcd_fixed_write (object, unit) class(alpha_qcd_fixed_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QCD parameters (fixed coupling):" write (u, "(5x,A," // FMT_12 // ")") "alpha = ", object%val end subroutine alpha_qcd_fixed_write @ %def alpha_qcd_fixed_write @ Calculation: the scale is ignored in this case. <>= procedure :: get => alpha_qcd_fixed_get +<>= + module function alpha_qcd_fixed_get (alpha_qcd, scale) result (alpha) + class(alpha_qcd_fixed_t), intent(in) :: alpha_qcd + real(default), intent(in) :: scale + real(default) :: alpha + end function alpha_qcd_fixed_get <>= - function alpha_qcd_fixed_get (alpha_qcd, scale) result (alpha) + module function alpha_qcd_fixed_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_fixed_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = alpha_qcd%val end function alpha_qcd_fixed_get @ %def alpha_qcd_fixed_get @ \subsection{Running Coupling} In this version, the $\alpha_s$ value runs relative to the value at a given reference scale. There are two parameters: the value of this scale (default: $M_Z$), the value of $\alpha_s$ at this scale, and the number of effective flavors. Furthermore, we have the order of the approximation. <>= public :: alpha_qcd_from_scale_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_from_scale_t real(default) :: mu_ref = MZ_REF real(default) :: ref = ALPHA_QCD_MZ_REF integer :: order = 0 integer :: nf = 5 contains <> end type alpha_qcd_from_scale_t @ %def alpha_qcd_from_scale_t @ Output. <>= procedure :: write => alpha_qcd_from_scale_write +<>= + module subroutine alpha_qcd_from_scale_write (object, unit) + class(alpha_qcd_from_scale_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine alpha_qcd_from_scale_write <>= - subroutine alpha_qcd_from_scale_write (object, unit) + module subroutine alpha_qcd_from_scale_write (object, unit) class(alpha_qcd_from_scale_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QCD parameters (running coupling):" write (u, "(5x,A," // FMT_12 // ")") "Scale mu = ", object%mu_ref write (u, "(5x,A," // FMT_12 // ")") "alpha(mu) = ", object%ref write (u, "(5x,A,I0)") "LL order = ", object%order write (u, "(5x,A,I0)") "N(flv) = ", object%nf end subroutine alpha_qcd_from_scale_write @ %def alpha_qcd_from_scale_write @ Calculation: here, we call the function for running $\alpha_s$ that was defined in [[sm_physics]] above. The function does not take into account thresholds, so the number of flavors should be the correct one for the chosen scale. Normally, this should be the $Z$ boson mass. <>= procedure :: get => alpha_qcd_from_scale_get +<>= + module function alpha_qcd_from_scale_get (alpha_qcd, scale) result (alpha) + class(alpha_qcd_from_scale_t), intent(in) :: alpha_qcd + real(default), intent(in) :: scale + real(default) :: alpha + end function alpha_qcd_from_scale_get <>= - function alpha_qcd_from_scale_get (alpha_qcd, scale) result (alpha) + module function alpha_qcd_from_scale_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_from_scale_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = running_as (scale, alpha_qcd%ref, alpha_qcd%mu_ref, & alpha_qcd%order, real (alpha_qcd%nf, kind=default)) end function alpha_qcd_from_scale_get @ %def alpha_qcd_from_scale_get @ \subsection{Running Coupling, determined by $\Lambda_{\text{QCD}}$} In this version, the inputs are the value $\Lambda_{\text{QCD}}$ and the order of the approximation. <>= public :: alpha_qcd_from_lambda_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_from_lambda_t real(default) :: lambda = LAMBDA_QCD_REF integer :: order = 0 integer :: nf = 5 contains <> end type alpha_qcd_from_lambda_t @ %def alpha_qcd_from_lambda_t @ Output. <>= procedure :: write => alpha_qcd_from_lambda_write +<>= + module subroutine alpha_qcd_from_lambda_write (object, unit) + class(alpha_qcd_from_lambda_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine alpha_qcd_from_lambda_write <>= - subroutine alpha_qcd_from_lambda_write (object, unit) + module subroutine alpha_qcd_from_lambda_write (object, unit) class(alpha_qcd_from_lambda_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QCD parameters (Lambda_QCD as input):" write (u, "(5x,A," // FMT_12 // ")") "Lambda_QCD = ", object%lambda write (u, "(5x,A,I0)") "LL order = ", object%order write (u, "(5x,A,I0)") "N(flv) = ", object%nf end subroutine alpha_qcd_from_lambda_write @ %def alpha_qcd_from_lambda_write @ Calculation: here, we call the second function for running $\alpha_s$ that was defined in [[sm_physics]] above. The $\Lambda$ value should be the one that is appropriate for the chosen number of effective flavors. Again, thresholds are not incorporated. <>= procedure :: get => alpha_qcd_from_lambda_get +<>= + module function alpha_qcd_from_lambda_get (alpha_qcd, scale) result (alpha) + class(alpha_qcd_from_lambda_t), intent(in) :: alpha_qcd + real(default), intent(in) :: scale + real(default) :: alpha + end function alpha_qcd_from_lambda_get <>= - function alpha_qcd_from_lambda_get (alpha_qcd, scale) result (alpha) + module function alpha_qcd_from_lambda_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_from_lambda_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = running_as_lam (real (alpha_qcd%nf, kind=default), scale, & alpha_qcd%lambda, alpha_qcd%order) end function alpha_qcd_from_lambda_get @ %def alpha_qcd_from_lambda_get @ \subsection{QCD Wrapper type} We could get along with a polymorphic QCD type, but a monomorphic wrapper type with a polymorphic component is easier to handle and probably safer (w.r.t.\ compiler bugs). However, we keep the object transparent, so we can set the type-specific parameters directly (by a [[dispatch]] routine). <>= public :: qcd_t <>= type :: qcd_t class(alpha_qcd_t), allocatable :: alpha character(32) :: md5sum = "" integer :: n_f = -1 contains <> end type qcd_t @ %def qcd_t @ Output. We first print the polymorphic [[alpha]] which contains a headline, then any extra components. <>= procedure :: write => qcd_write +<>= + module subroutine qcd_write (qcd, unit, show_md5sum) + class(qcd_t), intent(in) :: qcd + integer, intent(in), optional :: unit + logical, intent(in), optional :: show_md5sum + end subroutine qcd_write <>= - subroutine qcd_write (qcd, unit, show_md5sum) + module subroutine qcd_write (qcd, unit, show_md5sum) class(qcd_t), intent(in) :: qcd integer, intent(in), optional :: unit logical, intent(in), optional :: show_md5sum logical :: show_md5 integer :: u u = given_output_unit (unit); if (u < 0) return show_md5 = .true.; if (present (show_md5sum)) show_md5 = show_md5sum if (allocated (qcd%alpha)) then call qcd%alpha%write (u) else write (u, "(3x,A)") "QCD parameters (coupling undefined)" end if if (show_md5 .and. qcd%md5sum /= "") & write (u, "(5x,A,A,A)") "md5sum = '", qcd%md5sum, "'" end subroutine qcd_write @ %def qcd_write @ Compute an MD5 sum for the [[alpha_s]] setup. This is done by writing them to a temporary file, using a standard format. <>= procedure :: compute_alphas_md5sum => qcd_compute_alphas_md5sum +<>= + module subroutine qcd_compute_alphas_md5sum (qcd) + class(qcd_t), intent(inout) :: qcd + integer :: unit + end subroutine qcd_compute_alphas_md5sum <>= - subroutine qcd_compute_alphas_md5sum (qcd) + module subroutine qcd_compute_alphas_md5sum (qcd) class(qcd_t), intent(inout) :: qcd integer :: unit if (allocated (qcd%alpha)) then unit = free_unit () open (unit, status="scratch", action="readwrite") call qcd%alpha%write (unit) rewind (unit) qcd%md5sum = md5sum (unit) close (unit) end if end subroutine qcd_compute_alphas_md5sum @ %def qcd_compute_alphas_md5sum @ @ Retrieve the MD5 sum of the qcd setup. <>= procedure :: get_md5sum => qcd_get_md5sum +<>= + module function qcd_get_md5sum (qcd) result (md5sum) + character(32) :: md5sum + class(qcd_t), intent(inout) :: qcd + end function qcd_get_md5sum <>= - function qcd_get_md5sum (qcd) result (md5sum) + module function qcd_get_md5sum (qcd) result (md5sum) character(32) :: md5sum class(qcd_t), intent(inout) :: qcd md5sum = qcd%md5sum end function qcd_get_md5sum @ %def qcd_get_md5sum @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sm_qcd_ut.f90]]>>= <> module sm_qcd_ut use unit_tests use sm_qcd_uti <> <> contains <> end module sm_qcd_ut @ %def sm_qcd_ut @ <<[[sm_qcd_uti.f90]]>>= <> module sm_qcd_uti <> use physics_defs, only: MZ_REF use sm_qcd <> <> contains <> end module sm_qcd_uti @ %def sm_qcd_ut @ API: driver for the unit tests below. <>= public :: sm_qcd_test <>= subroutine sm_qcd_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sm_qcd_test @ %def sm_qcd_test @ \subsubsection{QCD Coupling} We check two different implementations of the abstract QCD coupling. <>= call test (sm_qcd_1, "sm_qcd_1", & "running alpha_s", & u, results) <>= public :: sm_qcd_1 <>= subroutine sm_qcd_1 (u) integer, intent(in) :: u type(qcd_t) :: qcd write (u, "(A)") "* Test output: sm_qcd_1" write (u, "(A)") "* Purpose: compute running alpha_s" write (u, "(A)") write (u, "(A)") "* Fixed:" write (u, "(A)") allocate (alpha_qcd_fixed_t :: qcd%alpha) call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) deallocate (qcd%alpha) write (u, "(A)") "* Running from MZ (LO):" write (u, "(A)") allocate (alpha_qcd_from_scale_t :: qcd%alpha) call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from MZ (NLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_scale_t) alpha%order = 1 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from MZ (NNLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_scale_t) alpha%order = 2 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) deallocate (qcd%alpha) write (u, "(A)") "* Running from Lambda_QCD (LO):" write (u, "(A)") allocate (alpha_qcd_from_lambda_t :: qcd%alpha) call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from Lambda_QCD (NLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_lambda_t) alpha%order = 1 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from Lambda_QCD (NNLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_lambda_t) alpha%order = 2 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, "(A)") write (u, "(A)") "* Test output end: sm_qcd_1" end subroutine sm_qcd_1 @ %def sm_qcd_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{QED Coupling} On the surface similar to the QCD coupling module but much simpler. Only a fixed QED couping $\alpha_\text{em}$ is allowed. Can be extended later if we want to enable a running of $\alpha_\text{em}$ as well. <<[[sm_qed.f90]]>>= <> module sm_qed <> - use io_units - use format_defs, only: FMT_12 - use md5 use physics_defs - use sm_physics <> <> <> <> + interface +<> + end interface + +end module sm_qed +@ %def sm_qed +@ +<<[[sm_qed_sub.f90]]>>= +<> + +submodule (sm_qed) sm_qed_s + + use io_units + use format_defs, only: FMT_12 + use md5 + use sm_physics + + implicit none + contains <> -end module sm_qed -@ %def sm_qed +end submodule sm_qed_s + +@ %def sm_qed_s @ \subsection{Coupling: Abstract Data Type} This is the abstract version of the QCD coupling implementation. <>= public :: alpha_qed_t <>= type, abstract :: alpha_qed_t contains <> end type alpha_qed_t @ %def alpha_qed_t @ There must be an output routine. <>= procedure (alpha_qed_write), deferred :: write <>= abstract interface subroutine alpha_qed_write (object, unit) import class(alpha_qed_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qed_write end interface @ %def alpha_qed_write @ This method computes the running coupling, given a certain scale. All parameters (reference value, order of the approximation, etc.) must be set before calling this. <>= procedure (alpha_qed_get), deferred :: get <>= abstract interface function alpha_qed_get (alpha_qed, scale) result (alpha) import class(alpha_qed_t), intent(in) :: alpha_qed real(default), intent(in) :: scale real(default) :: alpha end function alpha_qed_get end interface @ %def alpha_qed_get @ \subsection{Fixed Coupling} In this version, the $\alpha$ value is fixed, the [[scale]] argument of the [[get]] method is ignored. There is only one parameter, the value. The default depends on the electroweak scheme chosen in the model. <>= public :: alpha_qed_fixed_t <>= type, extends (alpha_qed_t) :: alpha_qed_fixed_t real(default) :: val = ALPHA_QED_ME_REF contains <> end type alpha_qed_fixed_t @ %def alpha_qed_fixed_t @ Output. <>= procedure :: write => alpha_qed_fixed_write +<>= + module subroutine alpha_qed_fixed_write (object, unit) + class(alpha_qed_fixed_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine alpha_qed_fixed_write <>= - subroutine alpha_qed_fixed_write (object, unit) + module subroutine alpha_qed_fixed_write (object, unit) class(alpha_qed_fixed_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QED parameters (fixed coupling):" write (u, "(5x,A," // FMT_12 // ")") "alpha = ", object%val end subroutine alpha_qed_fixed_write @ %def alpha_qed_fixed_write @ Calculation: the scale is ignored in this case. <>= procedure :: get => alpha_qed_fixed_get +<>= + module function alpha_qed_fixed_get (alpha_qed, scale) result (alpha) + class(alpha_qed_fixed_t), intent(in) :: alpha_qed + real(default), intent(in) :: scale + real(default) :: alpha + end function alpha_qed_fixed_get <>= - function alpha_qed_fixed_get (alpha_qed, scale) result (alpha) + module function alpha_qed_fixed_get (alpha_qed, scale) result (alpha) class(alpha_qed_fixed_t), intent(in) :: alpha_qed real(default), intent(in) :: scale real(default) :: alpha alpha = alpha_qed%val end function alpha_qed_fixed_get @ %def alpha_qed_fixed_get @ \subsection{Running Coupling} In this version, the $\alpha$ value runs relative to the value at a given reference scale. There are two parameters: the value of this scale (default: $M_Z$), the value of $\alpha$ at this scale, and the number of effective flavors. Furthermore, we have the order of the approximation. <>= public :: alpha_qed_from_scale_t <>= type, extends (alpha_qed_t) :: alpha_qed_from_scale_t real(default) :: mu_ref = ME_REF real(default) :: ref = ALPHA_QED_ME_REF integer :: order = 0 integer :: nf = 5 integer :: nlep = 1 logical :: analytic = .true. contains <> end type alpha_qed_from_scale_t @ %def alpha_qed_from_scale_t @ Output. <>= procedure :: write => alpha_qed_from_scale_write +<>= + module subroutine alpha_qed_from_scale_write (object, unit) + class(alpha_qed_from_scale_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine alpha_qed_from_scale_write <>= - subroutine alpha_qed_from_scale_write (object, unit) + module subroutine alpha_qed_from_scale_write (object, unit) class(alpha_qed_from_scale_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QED parameters (running coupling):" write (u, "(5x,A," // FMT_12 // ")") "Scale mu = ", object%mu_ref write (u, "(5x,A," // FMT_12 // ")") "alpha(mu) = ", object%ref write (u, "(5x,A,I0)") "LL order = ", object%order write (u, "(5x,A,I0)") "N(flv) = ", object%nf write (u, "(5x,A,I0)") "N(lep) = ", object%nlep write (u, "(5x,A,L1)") "analytic = ", object%analytic end subroutine alpha_qed_from_scale_write @ %def alpha_qed_from_scale_write @ Calculation: here, we call the function for running $\alpha_s$ that was defined in [[sm_physics]] above. The function does not take into account thresholds, so the number of flavors should be the correct one for the chosen scale. Normally, this should be the $Z$ boson mass. <>= procedure :: get => alpha_qed_from_scale_get +<>= + module function alpha_qed_from_scale_get (alpha_qed, scale) result (alpha) + class(alpha_qed_from_scale_t), intent(in) :: alpha_qed + real(default), intent(in) :: scale + real(default) :: alpha + end function alpha_qed_from_scale_get <>= - function alpha_qed_from_scale_get (alpha_qed, scale) result (alpha) + module function alpha_qed_from_scale_get (alpha_qed, scale) result (alpha) class(alpha_qed_from_scale_t), intent(in) :: alpha_qed real(default), intent(in) :: scale real(default) :: alpha if (alpha_qed%analytic) then alpha = running_alpha (scale, alpha_qed%ref, alpha_qed%mu_ref, & alpha_qed%order, alpha_qed%nf, alpha_qed%nlep) else alpha = running_alpha_num (scale, alpha_qed%ref, alpha_qed%mu_ref, & alpha_qed%order, alpha_qed%nf, alpha_qed%nlep) end if end function alpha_qed_from_scale_get @ %def alpha_qed_from_scale_get @ \subsection{QED type} This module is similar to [[qcd_t]], defining the type [[qed_t]]. It stores the [[alpha_qed_t]] type which is either constant or a running $\alpha$ with different options. <>= public :: qed_t <>= type :: qed_t class(alpha_qed_t), allocatable :: alpha character(32) :: md5sum = "" integer :: n_f = -1 integer :: n_lep = -1 contains <> end type qed_t @ %def qed_t Output. We first print the polymorphic [[alpha]] which contains a headline, then any extra components. <>= procedure :: write => qed_write +<>= + module subroutine qed_write (qed, unit, show_md5sum) + class(qed_t), intent(in) :: qed + integer, intent(in), optional :: unit + logical, intent(in), optional :: show_md5sum + end subroutine qed_write <>= - subroutine qed_write (qed, unit, show_md5sum) + module subroutine qed_write (qed, unit, show_md5sum) class(qed_t), intent(in) :: qed integer, intent(in), optional :: unit logical, intent(in), optional :: show_md5sum logical :: show_md5 integer :: u u = given_output_unit (unit); if (u < 0) return show_md5 = .true.; if (present (show_md5sum)) show_md5 = show_md5sum if (allocated (qed%alpha)) then call qed%alpha%write (u) else write (u, "(3x,A)") "QED parameters (coupling undefined)" end if if (show_md5 .and. qed%md5sum /= "") & write (u, "(5x,A,A,A)") "md5sum = '", qed%md5sum, "'" end subroutine qed_write @ % def qed_write @ Compute an MD5 sum for the [[alpha]] setup. This is done by writing them to a temporary file, using a standard format. <>= procedure :: compute_alpha_md5sum => qed_compute_alpha_md5sum +<>= + module subroutine qed_compute_alpha_md5sum (qed) + class(qed_t), intent(inout) :: qed + integer :: unit + end subroutine qed_compute_alpha_md5sum <>= - subroutine qed_compute_alpha_md5sum (qed) + module subroutine qed_compute_alpha_md5sum (qed) class(qed_t), intent(inout) :: qed integer :: unit if (allocated (qed%alpha)) then unit = free_unit () open (unit, status="scratch", action="readwrite") call qed%alpha%write (unit) rewind (unit) qed%md5sum = md5sum (unit) close (unit) end if end subroutine qed_compute_alpha_md5sum @ %def qed_compute_alphas_md5sum @ @ Retrieve the MD5 sum of the qed setup. <>= procedure :: get_md5sum => qed_get_md5sum +<>= + module function qed_get_md5sum (qed) result (md5sum) + character(32) :: md5sum + class(qed_t), intent(inout) :: qed + end function qed_get_md5sum <>= - function qed_get_md5sum (qed) result (md5sum) + module function qed_get_md5sum (qed) result (md5sum) character(32) :: md5sum class(qed_t), intent(inout) :: qed md5sum = qed%md5sum end function qed_get_md5sum @ %def qed_get_md5sum @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sm_qed_ut.f90]]>>= <> module sm_qed_ut use unit_tests use sm_qed_uti <> <> contains <> end module sm_qed_ut @ %def sm_qed_ut @ <<[[sm_qed_uti.f90]]>>= <> module sm_qed_uti <> use physics_defs, only: ME_REF use sm_qed <> <> contains <> end module sm_qed_uti @ %def sm_qed_ut @ API: driver for the unit tests below. <>= public :: sm_qed_test <>= subroutine sm_qed_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sm_qed_test @ %def sm_qed_test @ \subsubsection{QED Coupling} We check two different implementations of the abstract QED coupling. <>= call test (sm_qed_1, "sm_qed_1", & "running alpha_s", & u, results) <>= public :: sm_qed_1 <>= subroutine sm_qed_1 (u) integer, intent(in) :: u type(qed_t) :: qed write (u, "(A)") "* Test output: sm_qed_1" write (u, "(A)") "* Purpose: compute running alpha" write (u, "(A)") write (u, "(A)") "* Fixed:" write (u, "(A)") allocate (alpha_qed_fixed_t :: qed%alpha) call qed%compute_alpha_md5sum () call qed%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha (me) =", & qed%alpha%get (ME_REF) write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", & qed%alpha%get (10._default) write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", & qed%alpha%get (1000._default) write (u, *) deallocate (qed%alpha) write (u, "(A)") "* Running from me (LO):" write (u, "(A)") allocate (alpha_qed_from_scale_t :: qed%alpha) call qed%compute_alpha_md5sum () call qed%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha (me) =", & qed%alpha%get (ME_REF) write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", & qed%alpha%get (10._default) write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", & qed%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from me (NLO, analytic):" write (u, "(A)") select type (alpha => qed%alpha) type is (alpha_qed_from_scale_t) alpha%order = 1 end select call qed%compute_alpha_md5sum () call qed%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha (me) =", & qed%alpha%get (ME_REF) write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", & qed%alpha%get (10._default) write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", & qed%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from me (NLO, numeric):" write (u, "(A)") select type (alpha => qed%alpha) type is (alpha_qed_from_scale_t) alpha%order = 1 alpha%analytic = .false. end select call qed%compute_alpha_md5sum () call qed%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha (me) =", & qed%alpha%get (ME_REF) write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", & qed%alpha%get (10._default) write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", & qed%alpha%get (1000._default) write (u, *) deallocate (qed%alpha) write (u, "(A)") write (u, "(A)") "* Test output end: sm_qed_1" end subroutine sm_qed_1 @ %def sm_qed_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Shower algorithms} <<[[shower_algorithms.f90]]>>= <> module shower_algorithms <> - use diagnostics - use constants <> -<> +<> -<> +<> + + interface +<> + end interface + +end module shower_algorithms +@ %def shower_algorithms +<<[[shower_algorithms_sub.f90]]>>= +<> + +submodule (shower_algorithms) shower_algorithms_s + + use diagnostics + use constants + + implicit none contains -<> +<> -<> +<> -end module shower_algorithms -@ %def shower_algorithms +end submodule shower_algorithms_s + +@ %def shower_algorithms_s +@ @ We want to generate emission variables [[x]]$\in\mathds{R}^d$ proportional to \begin{align} &\quad f(x)\; \Delta(f, h(x)) \quad\text{with}\\ \Delta(f, H) &= \exp\left\{-\int\text{d}^d x'f(x') \Theta(h(x') - H)\right\} \end{align} The [[true_function]] $f$ is however too complicated and we are only able to generate [[x]] according to the [[overestimator]] $F$. This algorithm is described in Appendix B of 0709.2092 and is proven e.g.~in 1211.7204 and hep-ph/0606275. Intuitively speaking, we overestimate the emission probability and can therefore set [[scale_max = scale]] if the emission is rejected. -<>= - subroutine generate_vetoed (x, overestimator, true_function, & +<>= + module subroutine generate_vetoed (x, overestimator, true_function, & + sudakov, inverse_sudakov, scale_min) + real(default), dimension(:), intent(out) :: x + !class(rng_t), intent(inout) :: rng + procedure(XXX_function), pointer, intent(in) :: overestimator, true_function + procedure(sudakov_p), pointer, intent(in) :: sudakov, inverse_sudakov + real(default), intent(in) :: scale_min + end subroutine generate_vetoed +<>= + module subroutine generate_vetoed (x, overestimator, true_function, & sudakov, inverse_sudakov, scale_min) real(default), dimension(:), intent(out) :: x !class(rng_t), intent(inout) :: rng procedure(XXX_function), pointer, intent(in) :: overestimator, true_function procedure(sudakov_p), pointer, intent(in) :: sudakov, inverse_sudakov real(default), intent(in) :: scale_min real(default) :: random, scale_max, scale scale_max = inverse_sudakov (one) do while (scale_max > scale_min) !call rng%generate (random) scale = inverse_sudakov (random * sudakov (scale_max)) call generate_on_hypersphere (x, overestimator, scale) !call rng%generate (random) if (random < true_function (x) / overestimator (x)) then return !!! accept x end if scale_max = scale end do end subroutine generate_vetoed @ %def generate_vetoed @ -<>= +<>= subroutine generate_on_hypersphere (x, overestimator, scale) real(default), dimension(:), intent(out) :: x procedure(XXX_function), pointer, intent(in) :: overestimator real(default), intent(in) :: scale call msg_bug ("generate_on_hypersphere: not implemented") end subroutine generate_on_hypersphere @ %def generate_on_hypersphere @ -<>= +<>= interface pure function XXX_function (x) import real(default) :: XXX_function real(default), dimension(:), intent(in) :: x end function XXX_function end interface interface pure function sudakov_p (x) import real(default) :: sudakov_p real(default), intent(in) :: x end function sudakov_p end interface @ \subsection{Unit tests} (Currently unused.) -<>= +<>= public :: shower_algorithms_test -<>= +<>= subroutine shower_algorithms_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results - <> + <> end subroutine shower_algorithms_test @ %def shower_algorithms_test @ \subsubsection{Splitting functions} <>= call test (shower_algorithms_1, "shower_algorithms_1", & "veto technique", & u, results) <>= subroutine shower_algorithms_1 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: shower_algorithms_1" write (u, "(A)") "* Purpose: check veto technique" write (u, "(A)") write (u, "(A)") "* Splitting functions:" write (u, "(A)") !call assert (u, vanishes (p_qqg_pol (z, +1, -1, +1))) !call assert (u, nearly_equal ( & !p_qqg_pol (z, +1, +1, -1) + p_qqg_pol (z, +1, +1, +1), !p_qqg (z)) write (u, "(A)") write (u, "(A)") "* Test output end: shower_algorithms_1" end subroutine shower_algorithms_1 @ %def shower_algorithms_1 Index: trunk/src/physics/Makefile.am =================================================================== --- trunk/src/physics/Makefile.am (revision 8775) +++ trunk/src/physics/Makefile.am (revision 8776) @@ -1,203 +1,228 @@ ## Makefile.am -- Makefile for WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2021 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## The files in this directory implement physics definitions and functions ## for use in the WHIZARD generator. ## We create a library which is still to be combined with auxiliary libs. noinst_LTLIBRARIES = libphysics.la check_LTLIBRARIES = libphysics_ut.la libphysics_la_SOURCES = \ + $(PHYSICS_MODULES) \ + $(PHYSICS_SUBMODULES) + +PHYSICS_MODULES = \ physics_defs.f90 \ c_particles.f90 \ lorentz.f90 \ phs_points.f90 \ sm_physics.f90 \ sm_qcd.f90 \ sm_qed.f90 \ shower_algorithms.f90 +PHYSICS_SUBMODULES = \ + physics_defs_sub.f90 \ + c_particles_sub.f90 \ + lorentz_sub.f90 \ + phs_points_sub.f90 \ + sm_physics_sub.f90 \ + sm_qcd_sub.f90 \ + sm_qed_sub.f90 \ + shower_algorithms_sub.f90 + libphysics_ut_la_SOURCES = \ sm_physics_uti.f90 sm_physics_ut.f90 \ sm_qcd_uti.f90 sm_qcd_ut.f90 \ sm_qed_uti.f90 sm_qed_ut.f90 \ phs_points_uti.f90 phs_points_ut.f90 ## Omitting this would exclude it from the distribution dist_noinst_DATA = physics.nw # Modules and installation # Dump module names into file Modules execmoddir = $(fmoddir)/whizard nodist_execmod_HEADERS = \ - ${libphysics_la_SOURCES:.f90=.$(FCMOD)} + ${PHYSICS_MODULES:.f90=.$(FCMOD)} +# Submodules must not be included here libphysics_Modules = \ - ${libphysics_la_SOURCES:.f90=} \ + ${PHYSICS_MODULES:.f90=} \ ${libphysics_ut_la_SOURCES:.f90=} Modules: Makefile @for module in $(libphysics_Modules); do \ echo $$module >> $@.new; \ done @if diff $@ $@.new -q >/dev/null; then \ rm $@.new; \ else \ mv $@.new $@; echo "Modules updated"; \ fi BUILT_SOURCES = Modules ## Fortran module dependencies # Get module lists from other directories module_lists = \ ../basics/Modules \ ../utilities/Modules \ ../testing/Modules \ ../system/Modules \ ../combinatorics/Modules $(module_lists): $(MAKE) -C `dirname $@` Modules Module_dependencies.sed: $(libphysics_la_SOURCES) $(libphysics_ut_la_SOURCES) Module_dependencies.sed: $(module_lists) @rm -f $@ echo 's/, *only:.*//' >> $@ echo 's/, *&//' >> $@ echo 's/, *.*=>.*//' >> $@ echo 's/$$/.lo/' >> $@ for list in $(module_lists); do \ dir="`dirname $$list`"; \ for mod in `cat $$list`; do \ echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \ done \ done DISTCLEANFILES = Module_dependencies.sed # The following line just says # include Makefile.depend # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE @am__include@ @am__quote@Makefile.depend@am__quote@ Makefile.depend: Module_dependencies.sed Makefile.depend: $(libphysics_la_SOURCES) $(libphysics_ut_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -f Module_dependencies.sed; \ done > $@ DISTCLEANFILES += Makefile.depend # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: # touch $@ AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics +######################################################################## +# For the moment, the submodule dependencies will be hard-coded +physics_defs_sub.lo: physics_defs.lo +c_particles_sub.lo: c_particles.lo +lorentz_sub.lo: lorentz.lo +phs_points_sub.lo: phs_points.lo +sm_physics_sub.lo: sm_physics.lo +sm_qcd_sub.lo: sm_qcd.lo +sm_qed_sub.lo: sm_qed.lo +shower_algorithms_sub.lo: shower_algorithms.lo ######################################################################## ## Default Fortran compiler options ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif # MPI if FC_USE_MPI AM_FCFLAGS += $(FCFLAGS_MPI) endif ######################################################################## ## Non-standard targets and dependencies ## (Re)create F90 sources from NOWEB source. if NOWEB_AVAILABLE PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw physics.stamp: $(PRELUDE) $(srcdir)/physics.nw $(POSTLUDE) @rm -f physics.tmp @touch physics.tmp for src in $(libphysics_la_SOURCES) $(libphysics_ut_la_SOURCES); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done @mv -f physics.tmp physics.stamp $(libphysics_la_SOURCES) $(libphysics_ut_la_SOURCES): physics.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f physics.stamp; \ $(MAKE) $(AM_MAKEFLAGS) physics.stamp; \ fi endif ######################################################################## ## Non-standard cleanup tasks ## Remove sources that can be recreated using NOWEB if NOWEB_AVAILABLE maintainer-clean-noweb: -rm -f *.f90 *.c endif .PHONY: maintainer-clean-noweb ## Remove those sources also if builddir and srcdir are different if NOWEB_AVAILABLE clean-noweb: test "$(srcdir)" != "." && rm -f *.f90 *.c || true endif .PHONY: clean-noweb ## Remove F90 module files clean-local: clean-noweb -rm -f physics.stamp physics.tmp -rm -f *.$(FCMOD) if FC_SUBMODULES - -rm -f *.smod + -rm -f *.smod *.sub endif ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup Index: trunk/src/beams/beams.nw =================================================================== --- trunk/src/beams/beams.nw (revision 8775) +++ trunk/src/beams/beams.nw (revision 8776) @@ -1,25479 +1,25483 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: beams and beam structure %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Beams} \includemodulegraph{beams} These modules implement beam configuration and beam structure, the latter in abstract terms. \begin{description} \item[beam\_structures] The [[beam_structure_t]] type is a messenger type that communicates the user settings to the \whizard\ core. \item[beams] Beam configuration. \item[sf\_aux] Tools for handling structure functions and splitting \item[sf\_mappings] Mapping functions, useful for structure function implementation \item[sf\_base] The abstract structure-function interaction and structure-function chain types. \end{description} These are the implementation modules, the concrete counterparts of [[sf_base]]: \begin{description} \item[sf\_isr] ISR structure function (photon radiation inclusive and resummed in collinear and IR regions). \item[sf\_epa] Effective Photon Approximation. \item[sf\_ewa] Effective $W$ (and $Z$) approximation. \item[sf\_escan] Energy spectrum that emulates a uniform energy scan. \item[sf\_gaussian] Gaussian beam spread \item[sf\_beam\_events] Beam-event generator that reads its input from an external file. \item[sf\_circe1] CIRCE1 beam spectra for electrons and photons. \item[sf\_circe2] CIRCE2 beam spectra for electrons and photons. \item[hoppet\_interface] Support for $b$-quark matching, addon to PDF modules. \item[sf\_pdf\_builtin] Direct support for selected hadron PDFs. \item[sf\_lhapdf] LHAPDF library support. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Beam structure} This module stores the beam structure definition as it is declared in the SINDARIN script. The structure definition is not analyzed, just recorded for later use. We do not capture any numerical parameters, just names of particles and structure functions. <<[[beam_structures.f90]]>>= <> module beam_structures <> <> use io_units use format_defs, only: FMT_19 use diagnostics use lorentz use polarizations <> <> <> <> contains <> end module beam_structures @ %def beam_structures @ \subsection{Beam structure elements} An entry in a beam-structure record consists of a string that denotes a type of structure function. <>= type :: beam_structure_entry_t logical :: is_valid = .false. type(string_t) :: name contains <> end type beam_structure_entry_t @ %def beam_structure_entry_t @ Output. <>= procedure :: to_string => beam_structure_entry_to_string <>= function beam_structure_entry_to_string (object) result (string) class(beam_structure_entry_t), intent(in) :: object type(string_t) :: string if (object%is_valid) then string = object%name else string = "none" end if end function beam_structure_entry_to_string @ %def beam_structure_entry_to_string @ A record in the beam-structure sequence denotes either a structure-function entry, a pair of such entries, or a pair spectrum. <>= type :: beam_structure_record_t type(beam_structure_entry_t), dimension(:), allocatable :: entry end type beam_structure_record_t @ %def beam_structure_record_t @ \subsection{Beam structure type} The beam-structure object contains the beam particle(s) as simple strings. The sequence of records indicates the structure functions by name. No numerical parameters are stored. <>= public :: beam_structure_t <>= type :: beam_structure_t private integer :: n_beam = 0 type(string_t), dimension(:), allocatable :: prt type(beam_structure_record_t), dimension(:), allocatable :: record type(smatrix_t), dimension(:), allocatable :: smatrix real(default), dimension(:), allocatable :: pol_f real(default), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: theta real(default), dimension(:), allocatable :: phi contains <> end type beam_structure_t @ %def beam_structure_t @ The finalizer deletes all contents explicitly, so we can continue with an empty beam record. (It is not needed for deallocation.) We have distinct finalizers for the independent parts of the beam structure. <>= procedure :: final_sf => beam_structure_final_sf <>= subroutine beam_structure_final_sf (object) class(beam_structure_t), intent(inout) :: object if (allocated (object%prt)) deallocate (object%prt) if (allocated (object%record)) deallocate (object%record) object%n_beam = 0 end subroutine beam_structure_final_sf @ %def beam_structure_final_sf @ Output. The actual information fits in a single line, therefore we can provide a [[to_string]] method. The [[show]] method also lists the current values of relevant global variables. <>= procedure :: write => beam_structure_write procedure :: to_string => beam_structure_to_string <>= subroutine beam_structure_write (object, unit) class(beam_structure_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A,A)") "Beam structure: ", char (object%to_string ()) if (allocated (object%smatrix)) then do i = 1, size (object%smatrix) write (u, "(3x,A,I0,A)") "polarization (beam ", i, "):" call object%smatrix(i)%write (u, indent=2) end do end if if (allocated (object%pol_f)) then write (u, "(3x,A,F10.7,:,',',F10.7)") "polarization degree =", & object%pol_f end if if (allocated (object%p)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "momentum =", object%p end if if (allocated (object%theta)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "angle th =", object%theta end if if (allocated (object%phi)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "angle ph =", object%phi end if end subroutine beam_structure_write function beam_structure_to_string (object, sf_only) result (string) class(beam_structure_t), intent(in) :: object logical, intent(in), optional :: sf_only type(string_t) :: string integer :: i, j logical :: with_beams with_beams = .true.; if (present (sf_only)) with_beams = .not. sf_only select case (object%n_beam) case (1) if (with_beams) then string = object%prt(1) else string = "" end if case (2) if (with_beams) then string = object%prt(1) // ", " // object%prt(2) else string = "" end if if (allocated (object%record)) then if (size (object%record) > 0) then if (with_beams) string = string // " => " do i = 1, size (object%record) if (i > 1) string = string // " => " do j = 1, size (object%record(i)%entry) if (j > 1) string = string // ", " string = string // object%record(i)%entry(j)%to_string () end do end do end if end if case default string = "[any particles]" end select end function beam_structure_to_string @ %def beam_structure_write beam_structure_to_string @ Initializer: dimension the beam structure record. Each array element denotes the number of entries for a record within the beam-structure sequence. The number of entries is either one or two, while the number of records is unlimited. <>= procedure :: init_sf => beam_structure_init_sf <>= subroutine beam_structure_init_sf (beam_structure, prt, dim_array) class(beam_structure_t), intent(inout) :: beam_structure type(string_t), dimension(:), intent(in) :: prt integer, dimension(:), intent(in), optional :: dim_array integer :: i call beam_structure%final_sf () beam_structure%n_beam = size (prt) allocate (beam_structure%prt (size (prt))) beam_structure%prt = prt if (present (dim_array)) then allocate (beam_structure%record (size (dim_array))) do i = 1, size (dim_array) allocate (beam_structure%record(i)%entry (dim_array(i))) end do else allocate (beam_structure%record (0)) end if end subroutine beam_structure_init_sf @ %def beam_structure_init_sf @ Set an entry, specified by record number and entry number. <>= procedure :: set_sf => beam_structure_set_sf <>= subroutine beam_structure_set_sf (beam_structure, i, j, name) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i, j type(string_t), intent(in) :: name associate (entry => beam_structure%record(i)%entry(j)) entry%name = name entry%is_valid = .true. end associate end subroutine beam_structure_set_sf @ %def beam_structure_set_sf @ Expand the beam-structure object. (i) For a pair spectrum, keep the entry. (ii) For a single-particle structure function written as a single entry, replace this by a record with two entries. (ii) For a record with two nontrivial entries, separate this into two records with one trivial entry each. To achieve this, we need a function that tells us whether an entry is a spectrum or a structure function. It returns 0 for a trivial entry, 1 for a single-particle structure function, and 2 for a two-particle spectrum. <>= abstract interface function strfun_mode_fun (name) result (n) import type(string_t), intent(in) :: name integer :: n end function strfun_mode_fun end interface @ %def is_spectrum_t @ Algorithm: (1) Mark entries as invalid where necessary. (2) Count the number of entries that we will need. (3) Expand and copy entries to a new record array. (4) Replace the old array by the new one. <>= procedure :: expand => beam_structure_expand <>= subroutine beam_structure_expand (beam_structure, strfun_mode) class(beam_structure_t), intent(inout) :: beam_structure procedure(strfun_mode_fun) :: strfun_mode type(beam_structure_record_t), dimension(:), allocatable :: new integer :: n_record, i, j if (.not. allocated (beam_structure%record)) return do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) do j = 1, size (entry) select case (strfun_mode (entry(j)%name)) case (0); entry(j)%is_valid = .false. end select end do end associate end do n_record = 0 do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) select case (size (entry)) case (1) if (entry(1)%is_valid) then select case (strfun_mode (entry(1)%name)) case (1); n_record = n_record + 2 case (2); n_record = n_record + 1 end select end if case (2) do j = 1, 2 if (entry(j)%is_valid) then select case (strfun_mode (entry(j)%name)) case (1); n_record = n_record + 1 case (2) call beam_structure%write () call msg_fatal ("Pair spectrum used as & &single-particle structure function") end select end if end do end select end associate end do allocate (new (n_record)) n_record = 0 do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) select case (size (entry)) case (1) if (entry(1)%is_valid) then select case (strfun_mode (entry(1)%name)) case (1) n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(1) = entry(1) n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(2) = entry(1) case (2) n_record = n_record + 1 allocate (new(n_record)%entry (1)) new(n_record)%entry(1) = entry(1) end select end if case (2) do j = 1, 2 if (entry(j)%is_valid) then n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(j) = entry(j) end if end do end select end associate end do call move_alloc (from = new, to = beam_structure%record) end subroutine beam_structure_expand @ %def beam_structure_expand @ \subsection{Polarization} To record polarization, we provide an allocatable array of [[smatrix]] objects, sparse matrices. The polarization structure is independent of the structure-function setup, they are combined only when an actual beam object is constructed. <>= procedure :: final_pol => beam_structure_final_pol procedure :: init_pol => beam_structure_init_pol <>= subroutine beam_structure_final_pol (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix) if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f) end subroutine beam_structure_final_pol subroutine beam_structure_init_pol (beam_structure, n) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: n if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix) allocate (beam_structure%smatrix (n)) if (.not. allocated (beam_structure%pol_f)) & allocate (beam_structure%pol_f (n), source = 1._default) end subroutine beam_structure_init_pol @ %def beam_structure_final_pol @ %def beam_structure_init_pol @ Check if polarized beams are used. <>= procedure :: has_polarized_beams => beam_structure_has_polarized_beams <>= elemental function beam_structure_has_polarized_beams (beam_structure) result (pol) logical :: pol class(beam_structure_t), intent(in) :: beam_structure if (allocated (beam_structure%pol_f)) then pol = any (beam_structure%pol_f /= 0) else pol = .false. end if end function beam_structure_has_polarized_beams @ %def beam_structure_has_polarized_beams @ Directly copy the spin density matrices. <>= procedure :: set_smatrix => beam_structure_set_smatrix <>= subroutine beam_structure_set_smatrix (beam_structure, i, smatrix) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i type(smatrix_t), intent(in) :: smatrix beam_structure%smatrix(i) = smatrix end subroutine beam_structure_set_smatrix @ %def beam_structure_set_smatrix @ Initialize one of the spin density matrices manually. <>= procedure :: init_smatrix => beam_structure_init_smatrix <>= subroutine beam_structure_init_smatrix (beam_structure, i, n_entry) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: n_entry call beam_structure%smatrix(i)%init (2, n_entry) end subroutine beam_structure_init_smatrix @ %def beam_structure_init_smatrix @ Set a polarization entry. <>= procedure :: set_sentry => beam_structure_set_sentry <>= subroutine beam_structure_set_sentry & (beam_structure, i, i_entry, index, value) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: i_entry integer, dimension(:), intent(in) :: index complex(default), intent(in) :: value call beam_structure%smatrix(i)%set_entry (i_entry, index, value) end subroutine beam_structure_set_sentry @ %def beam_structure_set_sentry @ Set the array of polarization fractions. <>= procedure :: set_pol_f => beam_structure_set_pol_f <>= subroutine beam_structure_set_pol_f (beam_structure, f) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: f if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f) allocate (beam_structure%pol_f (size (f)), source = f) end subroutine beam_structure_set_pol_f @ %def beam_structure_set_pol_f @ \subsection{Beam momenta} By default, beam momenta are deduced from the [[sqrts]] value or from the mass of the decaying particle, assuming a c.m.\ setup. Here we set them explicitly. <>= procedure :: final_mom => beam_structure_final_mom <>= subroutine beam_structure_final_mom (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure if (allocated (beam_structure%p)) deallocate (beam_structure%p) if (allocated (beam_structure%theta)) deallocate (beam_structure%theta) if (allocated (beam_structure%phi)) deallocate (beam_structure%phi) end subroutine beam_structure_final_mom @ %def beam_structure_final_mom <>= procedure :: set_momentum => beam_structure_set_momentum procedure :: set_theta => beam_structure_set_theta procedure :: set_phi => beam_structure_set_phi <>= subroutine beam_structure_set_momentum (beam_structure, p) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: p if (allocated (beam_structure%p)) deallocate (beam_structure%p) allocate (beam_structure%p (size (p)), source = p) end subroutine beam_structure_set_momentum subroutine beam_structure_set_theta (beam_structure, theta) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: theta if (allocated (beam_structure%theta)) deallocate (beam_structure%theta) allocate (beam_structure%theta (size (theta)), source = theta) end subroutine beam_structure_set_theta subroutine beam_structure_set_phi (beam_structure, phi) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: phi if (allocated (beam_structure%phi)) deallocate (beam_structure%phi) allocate (beam_structure%phi (size (phi)), source = phi) end subroutine beam_structure_set_phi @ %def beam_structure_set_momentum @ %def beam_structure_set_theta @ %def beam_structure_set_phi @ \subsection{Get contents} Look at the incoming particles. We may also have the case that beam particles are not specified, but polarization. <>= procedure :: is_set => beam_structure_is_set procedure :: get_n_beam => beam_structure_get_n_beam procedure :: get_prt => beam_structure_get_prt <>= function beam_structure_is_set (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = beam_structure%n_beam > 0 .or. beam_structure%asymmetric () end function beam_structure_is_set function beam_structure_get_n_beam (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n n = beam_structure%n_beam end function beam_structure_get_n_beam function beam_structure_get_prt (beam_structure) result (prt) class(beam_structure_t), intent(in) :: beam_structure type(string_t), dimension(:), allocatable :: prt allocate (prt (size (beam_structure%prt))) prt = beam_structure%prt end function beam_structure_get_prt @ %def beam_structure_is_set @ %def beam_structure_get_n_beam @ %def beam_structure_get_prt @ Return the number of records. <>= procedure :: get_n_record => beam_structure_get_n_record <>= function beam_structure_get_n_record (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n if (allocated (beam_structure%record)) then n = size (beam_structure%record) else n = 0 end if end function beam_structure_get_n_record @ %def beam_structure_get_n_record @ Return an array consisting of the beam indices affected by the valid entries within a record. After expansion, there should be exactly one valid entry per record. <>= procedure :: get_i_entry => beam_structure_get_i_entry <>= function beam_structure_get_i_entry (beam_structure, i) result (i_entry) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i integer, dimension(:), allocatable :: i_entry associate (record => beam_structure%record(i)) select case (size (record%entry)) case (1) if (record%entry(1)%is_valid) then allocate (i_entry (2), source = [1, 2]) else allocate (i_entry (0)) end if case (2) if (all (record%entry%is_valid)) then allocate (i_entry (2), source = [1, 2]) else if (record%entry(1)%is_valid) then allocate (i_entry (1), source = [1]) else if (record%entry(2)%is_valid) then allocate (i_entry (1), source = [2]) else allocate (i_entry (0)) end if end select end associate end function beam_structure_get_i_entry @ %def beam_structure_get_i_entry @ Return the name of the first valid entry within a record. After expansion, there should be exactly one valid entry per record. <>= procedure :: get_name => beam_structure_get_name <>= function beam_structure_get_name (beam_structure, i) result (name) type(string_t) :: name class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i associate (record => beam_structure%record(i)) if (record%entry(1)%is_valid) then name = record%entry(1)%name else if (size (record%entry) == 2) then name = record%entry(2)%name end if end associate end function beam_structure_get_name @ %def beam_structure_get_name @ <>= procedure :: has_pdf => beam_structure_has_pdf <>= function beam_structure_has_pdf (beam_structure) result (has_pdf) logical :: has_pdf class(beam_structure_t), intent(in) :: beam_structure integer :: i type(string_t) :: name has_pdf = .false. do i = 1, beam_structure%get_n_record () name = beam_structure%get_name (i) has_pdf = has_pdf .or. name == var_str ("pdf_builtin") .or. name == var_str ("lhapdf") end do end function beam_structure_has_pdf @ %def beam_structure_has_pdf @ Return true if the beam structure contains a particular structure function identifier (such as [[lhapdf]], [[isr]], etc.) <>= procedure :: contains => beam_structure_contains <>= function beam_structure_contains (beam_structure, name) result (flag) class(beam_structure_t), intent(in) :: beam_structure character(*), intent(in) :: name logical :: flag integer :: i, j flag = .false. if (allocated (beam_structure%record)) then do i = 1, size (beam_structure%record) do j = 1, size (beam_structure%record(i)%entry) flag = beam_structure%record(i)%entry(j)%name == name if (flag) return end do end do end if end function beam_structure_contains @ %def beam_structure_contains @ Return polarization data. <>= procedure :: polarized => beam_structure_polarized procedure :: get_smatrix => beam_structure_get_smatrix procedure :: get_pol_f => beam_structure_get_pol_f procedure :: asymmetric => beam_structure_asymmetric <>= function beam_structure_polarized (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = allocated (beam_structure%smatrix) end function beam_structure_polarized function beam_structure_get_smatrix (beam_structure) result (smatrix) class(beam_structure_t), intent(in) :: beam_structure type(smatrix_t), dimension(:), allocatable :: smatrix allocate (smatrix (size (beam_structure%smatrix)), & source = beam_structure%smatrix) end function beam_structure_get_smatrix function beam_structure_get_pol_f (beam_structure) result (pol_f) class(beam_structure_t), intent(in) :: beam_structure real(default), dimension(:), allocatable :: pol_f allocate (pol_f (size (beam_structure%pol_f)), & source = beam_structure%pol_f) end function beam_structure_get_pol_f function beam_structure_asymmetric (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = allocated (beam_structure%p) & .or. allocated (beam_structure%theta) & .or. allocated (beam_structure%phi) end function beam_structure_asymmetric @ %def beam_structure_polarized @ %def beam_structure_get_smatrix @ %def beam_structure_get_pol_f @ %def beam_structure_asymmetric @ Return the beam momenta (the space part, i.e., three-momenta). This is meaningful only if momenta and, optionally, angles have been set. <>= procedure :: get_momenta => beam_structure_get_momenta <>= function beam_structure_get_momenta (beam_structure) result (p) class(beam_structure_t), intent(in) :: beam_structure type(vector3_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: theta, phi integer :: n, i if (allocated (beam_structure%p)) then n = size (beam_structure%p) if (allocated (beam_structure%theta)) then if (size (beam_structure%theta) == n) then allocate (theta (n), source = beam_structure%theta) else call msg_fatal ("Beam structure: mismatch in momentum vs. & &angle theta specification") end if else allocate (theta (n), source = 0._default) end if if (allocated (beam_structure%phi)) then if (size (beam_structure%phi) == n) then allocate (phi (n), source = beam_structure%phi) else call msg_fatal ("Beam structure: mismatch in momentum vs. & &angle phi specification") end if else allocate (phi (n), source = 0._default) end if allocate (p (n)) do i = 1, n p(i) = beam_structure%p(i) * vector3_moving ([ & sin (theta(i)) * cos (phi(i)), & sin (theta(i)) * sin (phi(i)), & cos (theta(i))]) end do if (n == 2) p(2) = - p(2) else call msg_fatal ("Beam structure: angle theta/phi specified but & &momentum/a p undefined") end if end function beam_structure_get_momenta @ %def beam_structure_get_momenta @ Check for a complete beam structure. The [[applies]] flag tells if the beam structure should actually be used for a process with the given [[n_in]] number of incoming particles. It set if the beam structure matches the process as either decay or scattering. It is unset if beam structure references a scattering setup but the process is a decay. It is also unset if the beam structure itself is empty. If the beam structure cannot be used, terminate with fatal error. <>= procedure :: check_against_n_in => beam_structure_check_against_n_in <>= subroutine beam_structure_check_against_n_in (beam_structure, n_in, applies) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: n_in logical, intent(out) :: applies if (beam_structure%is_set ()) then if (n_in == beam_structure%get_n_beam ()) then applies = .true. else if (beam_structure%get_n_beam () == 0) then call msg_fatal & ("Asymmetric beams: missing beam particle specification") applies = .false. else call msg_fatal & ("Mismatch of process and beam setup (scattering/decay)") applies = .false. end if else applies = .false. end if end subroutine beam_structure_check_against_n_in @ %def beam_structure_check_against_n_in @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[beam_structures_ut.f90]]>>= <> module beam_structures_ut use unit_tests use beam_structures_uti <> <> contains <> end module beam_structures_ut @ %def beam_structures_ut @ <<[[beam_structures_uti.f90]]>>= <> module beam_structures_uti <> <> use beam_structures <> <> contains <> <> end module beam_structures_uti @ %def beam_structures_ut @ API: driver for the unit tests below. <>= public :: beam_structures_test <>= subroutine beam_structures_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine beam_structures_test @ %def beam_structures_tests @ \subsubsection{Empty structure} <>= call test (beam_structures_1, "beam_structures_1", & "empty beam structure record", & u, results) <>= public :: beam_structures_1 <>= subroutine beam_structures_1 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure write (u, "(A)") "* Test output: beam_structures_1" write (u, "(A)") "* Purpose: display empty beam structure record" write (u, "(A)") call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_1" end subroutine beam_structures_1 @ %def beam_structures_1 @ \subsubsection{Nontrivial configurations} <>= call test (beam_structures_2, "beam_structures_2", & "beam structure records", & u, results) <>= public :: beam_structures_2 <>= subroutine beam_structures_2 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_2" write (u, "(A)") "* Purpose: setup beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [2]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [2, 1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%set_sf (2, 1, var_str ("c")) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_2" end subroutine beam_structures_2 @ %def beam_structures_2 @ \subsubsection{Expansion} Provide a function that tells, for the dummy structure function names used here, whether they are considered a two-particle spectrum or a single-particle structure function: <>= function test_strfun_mode (name) result (n) type(string_t), intent(in) :: name integer :: n select case (char (name)) case ("a"); n = 2 case ("b"); n = 1 case default; n = 0 end select end function test_strfun_mode @ %def test_ist_pair_spectrum @ <>= call test (beam_structures_3, "beam_structures_3", & "beam structure expansion", & u, results) <>= public :: beam_structures_3 <>= subroutine beam_structures_3 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_3" write (u, "(A)") "* Purpose: expand beam structure records" write (u, "(A)") s = "s" write (u, "(A)") "* Pair spectrum (keep as-is)" write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Structure function pair (expand)" write (u, "(A)") call beam_structure%init_sf ([s, s], [2]) call beam_structure%set_sf (1, 1, var_str ("b")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Structure function (separate and expand)" write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Combination" write (u, "(A)") call beam_structure%init_sf ([s, s], [1, 1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (2, 1, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_3" end subroutine beam_structures_3 @ %def beam_structures_3 @ \subsubsection{Public methods} Check the methods that can be called to get the beam-structure contents. <>= call test (beam_structures_4, "beam_structures_4", & "beam structure contents", & u, results) <>= public :: beam_structures_4 <>= subroutine beam_structures_4 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure type(string_t) :: s type(string_t), dimension(2) :: prt integer :: i write (u, "(A)") "* Test output: beam_structures_4" write (u, "(A)") "* Purpose: check the API" write (u, "(A)") s = "s" write (u, "(A)") "* Structure-function combination" write (u, "(A)") call beam_structure%init_sf ([s, s], [1, 2, 2]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (2, 1, var_str ("b")) call beam_structure%set_sf (3, 2, var_str ("c")) call beam_structure%write (u) write (u, *) write (u, "(1x,A,I0)") "n_beam = ", beam_structure%get_n_beam () prt = beam_structure%get_prt () write (u, "(1x,A,2(1x,A))") "prt =", char (prt(1)), char (prt(2)) write (u, *) write (u, "(1x,A,I0)") "n_record = ", beam_structure%get_n_record () do i = 1, 3 write (u, "(A)") write (u, "(1x,A,I0,A,A)") "name(", i, ") = ", & char (beam_structure%get_name (i)) write (u, "(1x,A,I0,A,2(1x,I0))") "i_entry(", i, ") =", & beam_structure%get_i_entry (i) end do write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_4" end subroutine beam_structures_4 @ %def beam_structures_4 @ \subsubsection{Polarization} The polarization properties are independent from the structure-function setup. <>= call test (beam_structures_5, "beam_structures_5", & "polarization", & u, results) <>= public :: beam_structures_5 <>= subroutine beam_structures_5 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_5" write (u, "(A)") "* Purpose: setup polarization in beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%init_pol (1) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default)) call beam_structure%set_pol_f ([0.5_default]) call beam_structure%write (u) write (u, "(A)") call beam_structure%final_sf () call beam_structure%final_pol () call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 2) call beam_structure%set_sentry (1, 1, [-1,1], (0.5_default,-0.5_default)) call beam_structure%set_sentry (1, 2, [ 1,1], (1._default, 0._default)) call beam_structure%init_smatrix (2, 0) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_5" end subroutine beam_structures_5 @ %def beam_structures_5 @ \subsubsection{Momenta} The momenta are independent from the structure-function setup. <>= call test (beam_structures_6, "beam_structures_6", & "momenta", & u, results) <>= public :: beam_structures_6 <>= subroutine beam_structures_6 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_6" write (u, "(A)") "* Purpose: setup momenta in beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%set_momentum ([500._default]) call beam_structure%write (u) write (u, "(A)") call beam_structure%final_sf () call beam_structure%final_mom () call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_momentum ([500._default, 700._default]) call beam_structure%set_theta ([0._default, 0.1_default]) call beam_structure%set_phi ([0._default, 1.51_default]) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_6" end subroutine beam_structures_6 @ %def beam_structures_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Beams for collisions and decays} <<[[beams.f90]]>>= <> module beams <> <> use io_units use format_defs, only: FMT_19 use numeric_utils use diagnostics use md5 use lorentz use model_data use flavors use quantum_numbers use state_matrices use interactions use polarizations use beam_structures <> <> <> <> contains <> end module beams @ %def beams @ \subsection{Beam data} The beam data type contains beam data for one or two beams, depending on whether we are dealing with beam collisions or particle decay. In addition, it holds the c.m.\ energy [[sqrts]], the Lorentz transformation [[L]] that transforms the c.m.\ system into the lab system, and the pair of c.m.\ momenta. <>= public :: beam_data_t <>= type :: beam_data_t logical :: initialized = .false. integer :: n = 0 type(flavor_t), dimension(:), allocatable :: flv real(default), dimension(:), allocatable :: mass type(pmatrix_t), dimension(:), allocatable :: pmatrix logical :: lab_is_cm = .true. type(vector4_t), dimension(:), allocatable :: p_cm type(vector4_t), dimension(:), allocatable :: p type(lorentz_transformation_t), allocatable :: L_cm_to_lab real(default) :: sqrts = 0 character(32) :: md5sum = "" contains <> end type beam_data_t @ %def beam_data_t @ Generic initializer. This is called by the specific initializers below. Initialize either for decay or for collision. <>= subroutine beam_data_init (beam_data, n) type(beam_data_t), intent(out) :: beam_data integer, intent(in) :: n beam_data%n = n allocate (beam_data%flv (n)) allocate (beam_data%mass (n)) allocate (beam_data%pmatrix (n)) allocate (beam_data%p_cm (n)) allocate (beam_data%p (n)) beam_data%initialized = .true. end subroutine beam_data_init @ %def beam_data_init @ Finalizer: needed for the polarization components of the beams. <>= procedure :: final => beam_data_final <>= subroutine beam_data_final (beam_data) class(beam_data_t), intent(inout) :: beam_data beam_data%initialized = .false. end subroutine beam_data_final @ %def beam_data_final @ The verbose (default) version is for debugging. The short version is for screen output in the UI. <>= procedure :: write => beam_data_write <>= subroutine beam_data_write (beam_data, unit, verbose, write_md5sum) class(beam_data_t), intent(in) :: beam_data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, write_md5sum integer :: prt_name_len logical :: verb, write_md5 integer :: u u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose write_md5 = verb; if (present (write_md5sum)) write_md5 = write_md5sum if (.not. beam_data%initialized) then write (u, "(1x,A)") "Beam data: [undefined]" return end if prt_name_len = maxval (len (beam_data%flv%get_name ())) select case (beam_data%n) case (1) write (u, "(1x,A)") "Beam data (decay):" if (verb) then call write_prt (1) call beam_data%pmatrix(1)%write (u) write (u, *) "R.f. momentum:" call vector4_write (beam_data%p_cm(1), u) write (u, *) "Lab momentum:" call vector4_write (beam_data%p(1), u) else call write_prt (1) end if case (2) write (u, "(1x,A)") "Beam data (collision):" if (verb) then call write_prt (1) call beam_data%pmatrix(1)%write (u) call write_prt (2) call beam_data%pmatrix(2)%write (u) call write_sqrts write (u, *) "C.m. momenta:" call vector4_write (beam_data%p_cm(1), u) call vector4_write (beam_data%p_cm(2), u) write (u, *) "Lab momenta:" call vector4_write (beam_data%p(1), u) call vector4_write (beam_data%p(2), u) else call write_prt (1) call write_prt (2) call write_sqrts end if end select if (allocated (beam_data%L_cm_to_lab)) then if (verb) then call lorentz_transformation_write (beam_data%L_cm_to_lab, u) else write (u, "(1x,A)") "Beam structure: lab and c.m. frame differ" end if end if if (write_md5) then write (u, *) "MD5 sum: ", beam_data%md5sum end if contains subroutine write_sqrts character(80) :: sqrts_str write (sqrts_str, "(" // FMT_19 // ")") beam_data%sqrts write (u, "(3x,A)") "sqrts = " // trim (adjustl (sqrts_str)) // " GeV" end subroutine write_sqrts subroutine write_prt (i) integer, intent(in) :: i character(80) :: name_str, mass_str write (name_str, "(A)") char (beam_data%flv(i)%get_name ()) write (mass_str, "(ES13.7)") beam_data%mass(i) write (u, "(3x,A)", advance="no") & name_str(:prt_name_len) // " (mass = " & // trim (adjustl (mass_str)) // " GeV)" if (beam_data%pmatrix(i)%is_polarized ()) then write (u, "(2x,A)") "polarized" else write (u, *) end if end subroutine write_prt end subroutine beam_data_write @ %def beam_data_write @ Return initialization status: <>= procedure :: are_valid => beam_data_are_valid <>= function beam_data_are_valid (beam_data) result (flag) class(beam_data_t), intent(in) :: beam_data logical :: flag flag = beam_data%initialized end function beam_data_are_valid @ %def beam_data_are_valid @ Check whether beam data agree with the current values of relevant parameters. <>= procedure :: check_scattering => beam_data_check_scattering <>= subroutine beam_data_check_scattering (beam_data, sqrts) class(beam_data_t), intent(in) :: beam_data real(default), intent(in), optional :: sqrts if (beam_data_are_valid (beam_data)) then if (present (sqrts)) then if (.not. nearly_equal (sqrts, beam_data%sqrts)) then call msg_error ("Current setting of sqrts is inconsistent " & // "with beam setup (ignored).") end if end if else call msg_bug ("Beam setup: invalid beam data") end if end subroutine beam_data_check_scattering @ %def beam_data_check_scattering @ Return the number of beams (1 for decays, 2 for collisions). <>= procedure :: get_n_in => beam_data_get_n_in <>= function beam_data_get_n_in (beam_data) result (n_in) class(beam_data_t), intent(in) :: beam_data integer :: n_in n_in = beam_data%n end function beam_data_get_n_in @ %def beam_data_get_n_in @ Return the beam flavor <>= procedure :: get_flavor => beam_data_get_flavor <>= function beam_data_get_flavor (beam_data) result (flv) class(beam_data_t), intent(in) :: beam_data type(flavor_t), dimension(:), allocatable :: flv allocate (flv (beam_data%n)) flv = beam_data%flv end function beam_data_get_flavor @ %def beam_data_get_flavor @ Return the beam energies <>= procedure :: get_energy => beam_data_get_energy <>= function beam_data_get_energy (beam_data) result (e) class(beam_data_t), intent(in) :: beam_data real(default), dimension(:), allocatable :: e integer :: i allocate (e (beam_data%n)) if (beam_data%initialized) then do i = 1, beam_data%n e(i) = energy (beam_data%p(i)) end do else e = 0 end if end function beam_data_get_energy @ %def beam_data_get_energy @ Return the c.m.\ energy. <>= procedure :: get_sqrts => beam_data_get_sqrts <>= function beam_data_get_sqrts (beam_data) result (sqrts) class(beam_data_t), intent(in) :: beam_data real(default) :: sqrts sqrts = beam_data%sqrts end function beam_data_get_sqrts @ %def beam_data_get_sqrts @ Return the polarization in case it is just two degrees <>= procedure :: get_polarization => beam_data_get_polarization <>= function beam_data_get_polarization (beam_data) result (pol) class(beam_data_t), intent(in) :: beam_data real(default), dimension(beam_data%n) :: pol pol = beam_data%pmatrix%get_simple_pol () end function beam_data_get_polarization @ %def beam_data_get_polarization @ <>= procedure :: get_helicity_state_matrix => beam_data_get_helicity_state_matrix <>= function beam_data_get_helicity_state_matrix (beam_data) result (state_hel) type(state_matrix_t) :: state_hel class(beam_data_t), intent(in) :: beam_data type(polarization_t), dimension(:), allocatable :: pol integer :: i allocate (pol (beam_data%n)) do i = 1, beam_data%n call pol(i)%init_pmatrix (beam_data%pmatrix(i)) end do call combine_polarization_states (pol, state_hel) end function beam_data_get_helicity_state_matrix @ %def beam_data_get_helicity_state_matrix @ <>= procedure :: is_initialized => beam_data_is_initialized <>= function beam_data_is_initialized (beam_data) result (initialized) logical :: initialized class(beam_data_t), intent(in) :: beam_data initialized = any (beam_data%pmatrix%exists ()) end function beam_data_is_initialized @ %def beam_data_is_initialized @ Return a MD5 checksum for beam data. If no checksum is present (because beams have not been initialized), compute the checksum of the sqrts value. <>= procedure :: get_md5sum => beam_data_get_md5sum <>= function beam_data_get_md5sum (beam_data, sqrts) result (md5sum_beams) class(beam_data_t), intent(in) :: beam_data real(default), intent(in) :: sqrts character(32) :: md5sum_beams character(80) :: buffer if (beam_data%md5sum /= "") then md5sum_beams = beam_data%md5sum else write (buffer, *) sqrts md5sum_beams = md5sum (buffer) end if end function beam_data_get_md5sum @ %def beam_data_get_md5sum @ \subsection{Initializers: beam structure} Initialize the beam data object from a beam structure object, given energy and model. <>= procedure :: init_structure => beam_data_init_structure <>= subroutine beam_data_init_structure & (beam_data, structure, sqrts, model, decay_rest_frame) class(beam_data_t), intent(out) :: beam_data type(beam_structure_t), intent(in) :: structure integer :: n_beam real(default), intent(in) :: sqrts class(model_data_t), intent(in), target :: model logical, intent(in), optional :: decay_rest_frame type(flavor_t), dimension(:), allocatable :: flv n_beam = structure%get_n_beam () allocate (flv (n_beam)) call flv%init (structure%get_prt (), model) if (structure%asymmetric ()) then if (structure%polarized ()) then call beam_data%init_momenta (structure%get_momenta (), flv, & structure%get_smatrix (), structure%get_pol_f ()) else call beam_data%init_momenta (structure%get_momenta (), flv) end if else select case (n_beam) case (1) if (structure%polarized ()) then call beam_data%init_decay (flv, & structure%get_smatrix (), structure%get_pol_f (), & rest_frame = decay_rest_frame) else call beam_data%init_decay (flv, & rest_frame = decay_rest_frame) end if case (2) if (structure%polarized ()) then call beam_data%init_sqrts (sqrts, flv, & structure%get_smatrix (), structure%get_pol_f ()) else call beam_data%init_sqrts (sqrts, flv) end if case default call msg_bug ("Beam data: invalid beam structure object") end select end if end subroutine beam_data_init_structure @ %def beam_data_init_structure @ \subsection{Initializers: collisions} This is the simplest one: just the two flavors, c.m.\ energy, polarization. Color is inferred from flavor. Beam momenta and c.m.\ momenta coincide. <>= procedure :: init_sqrts => beam_data_init_sqrts <>= subroutine beam_data_init_sqrts (beam_data, sqrts, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data real(default), intent(in) :: sqrts type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f real(default), dimension(size(flv)) :: E, p call beam_data_init (beam_data, size (flv)) beam_data%sqrts = sqrts beam_data%lab_is_cm = .true. select case (beam_data%n) case (1) E = sqrts; p = 0 beam_data%p_cm = vector4_moving (E, p, 3) beam_data%p = beam_data%p_cm case (2) beam_data%p_cm = colliding_momenta (sqrts, flv%get_mass ()) beam_data%p = colliding_momenta (sqrts, flv%get_mass ()) end select call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) end subroutine beam_data_init_sqrts @ %def beam_data_init_sqrts @ This version sets beam momenta directly, assuming that they are asymmetric, i.e., lab frame and c.m.\ frame do not coincide. Polarization info is deferred to a common initializer. The Lorentz transformation that we compute here is not actually used in the calculation; instead, it will be recomputed for each event in the subroutine [[phs_set_incoming_momenta]]. We compute it here for the nominal beam setup nevertheless, so we can print it and, in particular, include it in the MD5 sum. <>= procedure :: init_momenta => beam_data_init_momenta <>= subroutine beam_data_init_momenta (beam_data, p3, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data type(vector3_t), dimension(:), intent(in) :: p3 type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f type(vector4_t) :: p0 type(vector4_t), dimension(:), allocatable :: p, p_cm_rot real(default), dimension(size(p3)) :: e real(default), dimension(size(flv)) :: m type(lorentz_transformation_t) :: L_boost, L_rot call beam_data_init (beam_data, size (flv)) m = flv%get_mass () e = sqrt (p3 ** 2 + m ** 2) allocate (p (beam_data%n)) p = vector4_moving (e, p3) p0 = sum (p) beam_data%p = p beam_data%lab_is_cm = .false. beam_data%sqrts = p0 ** 1 L_boost = boost (p0, beam_data%sqrts) allocate (p_cm_rot (beam_data%n)) p_cm_rot = inverse (L_boost) * p allocate (beam_data%L_cm_to_lab) select case (beam_data%n) case (1) beam_data%L_cm_to_lab = L_boost beam_data%p_cm = vector4_at_rest (beam_data%sqrts) case (2) L_rot = rotation_to_2nd (3, space_part (p_cm_rot(1))) beam_data%L_cm_to_lab = L_boost * L_rot beam_data%p_cm = & colliding_momenta (beam_data%sqrts, flv%get_mass ()) end select call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) end subroutine beam_data_init_momenta @ %def beam_data_init_momenta @ Final steps: If requested, rotate the beams in the lab frame, and set the beam-data components. <>= subroutine beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) type(beam_data_t), intent(inout) :: beam_data type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f integer :: i do i = 1, beam_data%n beam_data%flv(i) = flv(i) beam_data%mass(i) = flv(i)%get_mass () if (present (smatrix)) then if (size (smatrix) /= beam_data%n) & call msg_fatal ("Beam data: & &polarization density array has wrong dimension") beam_data%pmatrix(i) = smatrix(i) if (present (pol_f)) then if (size (pol_f) /= size (smatrix)) & call msg_fatal ("Beam data: & &polarization fraction array has wrong dimension") call beam_data%pmatrix(i)%normalize (flv(i), pol_f(i)) else call beam_data%pmatrix(i)%normalize (flv(i), 1._default) end if else call beam_data%pmatrix(i)%init (2, 0) call beam_data%pmatrix(i)%normalize (flv(i), 0._default) end if end do call beam_data%compute_md5sum () end subroutine beam_data_finish_initialization @ %def beam_data_finish_initialization @ The MD5 sum is stored within the beam-data record, so it can be checked for integrity in subsequent runs. <>= procedure :: compute_md5sum => beam_data_compute_md5sum <>= subroutine beam_data_compute_md5sum (beam_data) class(beam_data_t), intent(inout) :: beam_data integer :: unit unit = free_unit () open (unit = unit, status = "scratch", action = "readwrite") call beam_data%write (unit, write_md5sum = .false., & verbose = .true.) rewind (unit) beam_data%md5sum = md5sum (unit) close (unit) end subroutine beam_data_compute_md5sum @ %def beam_data_compute_md5sum @ \subsection{Initializers: decays} This is the simplest one: decay in rest frame. We need just flavor and polarization. Color is inferred from flavor. Beam momentum and c.m.\ momentum coincide. <>= procedure :: init_decay => beam_data_init_decay <>= subroutine beam_data_init_decay (beam_data, flv, smatrix, pol_f, rest_frame) class(beam_data_t), intent(out) :: beam_data type(flavor_t), dimension(1), intent(in) :: flv type(smatrix_t), dimension(1), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f logical, intent(in), optional :: rest_frame real(default), dimension(1) :: m m = flv%get_mass () if (present (smatrix)) then call beam_data%init_sqrts (m(1), flv, smatrix, pol_f) else call beam_data%init_sqrts (m(1), flv, smatrix, pol_f) end if if (present (rest_frame)) beam_data%lab_is_cm = rest_frame end subroutine beam_data_init_decay @ %def beam_data_init_decay @ \subsection{The beams type} Beam objects are interaction objects that contain the actual beam data including polarization and density matrix. For collisions, the beam object actually contains two beams. <>= public :: beam_t <>= type :: beam_t private type(interaction_t) :: int end type beam_t @ %def beam_t @ The constructor contains code that converts beam data into the (entangled) particle-pair quantum state. First, we set the number of particles and polarization mask. (The polarization mask is handed over to all later interactions, so if helicity is diagonal or absent, this fact is used when constructing the hard-interaction events.) Then, we construct the entangled state that combines helicity, flavor and color of the two particles (where flavor and color are unique, while several helicity states are possible). Then, we transfer this state together with the associated values from the spin density matrix into the [[interaction_t]] object. Calling the [[add_state]] method of the interaction object, we keep the entries of the helicity density matrix without adding them up. This ensures that for unpolarized states, we do not normalize but end up with an $1/N$ entry, where $N$ is the initial-state multiplicity. <>= public :: beam_init <>= subroutine beam_init (beam, beam_data) type(beam_t), intent(out) :: beam type(beam_data_t), intent(in), target :: beam_data logical, dimension(beam_data%n) :: polarized, diagonal type(quantum_numbers_mask_t), dimension(beam_data%n) :: mask, mask_d type(state_matrix_t), target :: state_hel, state_fc, state_tmp type(state_iterator_t) :: it_hel, it_tmp type(quantum_numbers_t), dimension(:), allocatable :: qn complex(default) :: value real(default), parameter :: tolerance = 100 * epsilon (1._default) polarized = beam_data%pmatrix%is_polarized () diagonal = beam_data%pmatrix%is_diagonal () mask = quantum_numbers_mask (.false., .false., & mask_h = .not. polarized, & mask_hd = diagonal) mask_d = quantum_numbers_mask (.false., .false., .false., & mask_hd = polarized .and. diagonal) call beam%int%basic_init & (0, 0, beam_data%n, mask = mask, store_values = .true.) state_hel = beam_data%get_helicity_state_matrix () allocate (qn (beam_data%n)) call qn%init (beam_data%flv, color_from_flavor (beam_data%flv, 1)) call state_fc%init () call state_fc%add_state (qn) call merge_state_matrices (state_hel, state_fc, state_tmp) call it_hel%init (state_hel) call it_tmp%init (state_tmp) do while (it_hel%is_valid ()) qn = it_tmp%get_quantum_numbers () value = it_hel%get_matrix_element () if (any (qn%are_redundant (mask_d))) then ! skip off-diagonal elements for diagonal polarization else if (abs (value) <= tolerance) then ! skip zero entries else call beam%int%add_state (qn, value = value) end if call it_hel%advance () call it_tmp%advance () end do call beam%int%freeze () call beam%int%set_momenta (beam_data%p, outgoing = .true.) call state_hel%final () call state_fc%final () call state_tmp%final () end subroutine beam_init @ %def beam_init @ Finalizer: <>= public :: beam_final <>= subroutine beam_final (beam) type(beam_t), intent(inout) :: beam call beam%int%final () end subroutine beam_final @ %def beam_final @ I/O: <>= public :: beam_write <>= subroutine beam_write (beam, unit, verbose, show_momentum_sum, show_mass, col_verbose) type(beam_t), intent(in) :: beam integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: col_verbose integer :: u u = given_output_unit (unit); if (u < 0) return select case (beam%int%get_n_out ()) case (1); write (u, *) "Decaying particle:" case (2); write (u, *) "Colliding beams:" end select call beam%int%basic_write & (unit, verbose = verbose, show_momentum_sum = & show_momentum_sum, show_mass = show_mass, & col_verbose = col_verbose) end subroutine beam_write @ %def beam_write @ Defined assignment: deep copy <>= public :: assignment(=) <>= interface assignment(=) module procedure beam_assign end interface <>= subroutine beam_assign (beam_out, beam_in) type(beam_t), intent(out) :: beam_out type(beam_t), intent(in) :: beam_in beam_out%int = beam_in%int end subroutine beam_assign @ %def beam_assign @ \subsection{Inherited procedures} <>= public :: interaction_set_source_link <>= interface interaction_set_source_link module procedure interaction_set_source_link_beam end interface <>= subroutine interaction_set_source_link_beam (int, i, beam1, i1) type(interaction_t), intent(inout) :: int type(beam_t), intent(in), target :: beam1 integer, intent(in) :: i, i1 call int%set_source_link (i, beam1%int, i1) end subroutine interaction_set_source_link_beam @ %def interaction_set_source_link_beam @ \subsection{Accessing contents} Return the interaction component -- as a pointer, to avoid any copying. <>= public :: beam_get_int_ptr <>= function beam_get_int_ptr (beam) result (int) type(interaction_t), pointer :: int type(beam_t), intent(in), target :: beam int => beam%int end function beam_get_int_ptr @ %def beam_get_int_ptr @ Set beam momenta directly. (Used for cascade decays.) <>= public :: beam_set_momenta <>= subroutine beam_set_momenta (beam, p) type(beam_t), intent(inout) :: beam type(vector4_t), dimension(:), intent(in) :: p call beam%int%set_momenta (p) end subroutine beam_set_momenta @ %def beam_set_momenta @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[beams_ut.f90]]>>= <> module beams_ut use unit_tests use beams_uti <> <> contains <> end module beams_ut @ %def beams_ut @ <<[[beams_uti.f90]]>>= <> module beams_uti <> use lorentz use flavors use interactions, only: reset_interaction_counter use polarizations, only: smatrix_t use model_data use beam_structures use beams <> <> contains <> end module beams_uti @ %def beams_ut @ API: driver for the unit tests below. <>= public :: beams_test <>= subroutine beams_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine beams_test @ %def beams_test @ Test the basic beam setup. <>= call test (beam_1, "beam_1", & "check basic beam setup", & u, results) <>= public :: beam_1 <>= subroutine beam_1 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam real(default) :: sqrts type(flavor_t), dimension(2) :: flv type(smatrix_t), dimension(2) :: smatrix real(default), dimension(2) :: pol_f type(model_data_t), target :: model write (u, "(A)") "* Test output: beam_1" write (u, "(A)") "* Purpose: test basic beam setup" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call reset_interaction_counter () call model%init_sm_test () write (u, "(A)") "* Unpolarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Polarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call smatrix(1)%init (2, 1) call smatrix(1)%set_entry (1, [1,1], (1._default, 0._default)) pol_f(1) = 0.5_default call smatrix(2)%init (2, 3) call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default)) call smatrix(2)%set_entry (2, [-1,-1], (1._default, 0._default)) call smatrix(2)%set_entry (3, [-1,1], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call smatrix(1)%init (2, 0) pol_f(1) = 0._default call smatrix(2)%init (2, 1) call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call smatrix(1)%init (2, 0) pol_f(1) = 0._default call smatrix(2)%init (2, 1) call smatrix(2)%set_entry (1, [0,0], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_data%init_decay (flv(1:1)) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Polarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call smatrix(1)%init (2, 1) call smatrix(1)%set_entry (1, [0,0], (1._default, 0._default)) pol_f(1) = 0.4_default call beam_data%init_decay (flv(1:1), smatrix(1:1), pol_f(1:1)) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_1" end subroutine beam_1 @ %def beam_1 @ Test advanced beam setup. <>= call test (beam_2, "beam_2", & "beam initialization", & u, results) <>= public :: beam_2 <>= subroutine beam_2 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam real(default) :: sqrts type(flavor_t), dimension(2) :: flv integer, dimension(0) :: no_records type(beam_structure_t) :: beam_structure type(model_data_t), target :: model write (u, "(A)") "* Test output: beam_2" write (u, "(A)") "* Purpose: transfer beam polarization using & &beam structure" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Unpolarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Polarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [1,1], (1._default, 0._default)) call beam_structure%init_smatrix (2, 3) call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default)) call beam_structure%set_sentry (2, 2, [-1,-1], (1._default, 0._default)) call beam_structure%set_sentry (2, 3, [-1,1], (1._default, 0._default)) call beam_structure%set_pol_f ([0.5_default, 1._default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, *) call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () call beam_structure%final_pol () call beam_structure%final_sf () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 0) call beam_structure%init_smatrix (2, 1) call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default)) call beam_structure%set_pol_f ([0._default, 1._default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 0) call beam_structure%init_smatrix (2, 1) call beam_structure%set_sentry (2, 1, [0,0], (1._default, 0._default)) call beam_structure%write (u) write (u, "(A)") call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, "(A)") call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Polarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%init_pol (1) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default)) call beam_structure%set_pol_f ([0.4_default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_2" end subroutine beam_2 @ %def beam_2 @ Test advanced beam setup, completely arbitrary momenta. <>= call test (beam_3, "beam_3", & "generic beam momenta", & u, results) <>= public :: beam_3 <>= subroutine beam_3 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam type(flavor_t), dimension(2) :: flv integer, dimension(0) :: no_records type(model_data_t), target :: model type(beam_structure_t) :: beam_structure type(vector3_t), dimension(2) :: p3 type(vector4_t), dimension(2) :: p write (u, "(A)") "* Test output: beam_3" write (u, "(A)") "* Purpose: set up beams with generic momenta" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call reset_interaction_counter () call model%init_sm_test () write (u, "(A)") "* 1: Scattering process" write (u, "(A)") call flv%init ([2212,2212], model) p3(1) = vector3_moving ([5._default, 0._default, 10._default]) p3(2) = -vector3_moving ([1._default, 1._default, -10._default]) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%set_momentum (p3 ** 1) call beam_structure%set_theta (polar_angle (p3)) call beam_structure%set_phi (azimuthal_angle (p3)) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, 0._default, model) call pacify (beam_data%l_cm_to_lab, 1e-20_default) call beam_data%compute_md5sum () call beam_data%write (u, verbose = .true.) write (u, *) write (u, "(1x,A)") "Beam momenta reconstructed from LT:" p = beam_data%L_cm_to_lab * beam_data%p_cm call pacify (p, 1e-12_default) call vector4_write (p(1), u) call vector4_write (p(2), u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () call beam_structure%final_sf () call beam_structure%final_mom () write (u, "(A)") write (u, "(A)") "* 2: Decay" write (u, "(A)") call flv(1)%init (23, model) p3(1) = vector3_moving ([10._default, 5._default, 50._default]) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%set_momentum ([p3(1) ** 1]) call beam_structure%set_theta ([polar_angle (p3(1))]) call beam_structure%set_phi ([azimuthal_angle (p3(1))]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, 0._default, model) call beam_data%write (u, verbose = .true.) write (u, "(A)") write (u, "(1x,A)") "Beam momentum reconstructed from LT:" p(1) = beam_data%L_cm_to_lab * beam_data%p_cm(1) call pacify (p(1), 1e-12_default) call vector4_write (p(1), u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call beam_structure%final_sf () call beam_structure%final_mom () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_3" end subroutine beam_3 @ %def beam_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tools} This module contains auxiliary procedures that can be accessed by the structure function code. <<[[sf_aux.f90]]>>= <> module sf_aux <> use io_units use constants, only: twopi use numeric_utils use lorentz <> <> <> <> contains <> end module sf_aux @ %def sf_aux @ \subsection{Momentum splitting} Let us consider first an incoming parton with momentum $k$ and invariant mass squared $s=k^2$ that splits into two partons with momenta $q,p$ and invariant masses $t=q^2$ and $u=p^2$. (This is an abuse of the Mandelstam notation. $t$ is actually the momentum transfer, assuming that $p$ is radiated and $q$ initiates the hard process.) The energy is split among the partons such that if $E=k^0$, we have $q^0 = xE$ and $p^0=\bar x E$, where $\bar x\equiv 1-x$. We define the angle $\theta$ as the polar angle of $p$ w.r.t.\ the momentum axis of the incoming momentum $k$. Ignoring azimuthal angle, we can write the four-momenta in the basis $(E,p_T,p_L)$ as \begin{equation} k = \begin{pmatrix} E \\ 0 \\ p \end{pmatrix}, \qquad p = \begin{pmatrix} \bar x E \\ \bar x\bar p\sin\theta \\ \bar x\bar p\cos\theta \end{pmatrix}, \qquad q = \begin{pmatrix} x E \\ -\bar x\bar p\sin\theta \\ p - \bar x\bar p\cos\theta \end{pmatrix}, \end{equation} where the first two mass-shell conditions are \begin{equation} p^2 = E^2 - s, \qquad \bar p^2 = E^2 - \frac{u}{\bar x^2}. \end{equation} The second condition implies that, for positive $u$, $\bar x^2 > u/E^2$, or equivalently \begin{equation} x < 1 - \sqrt{u} / E. \end{equation} We are interested in the third mass-shell conditions: $s$ and $u$ are fixed, so we need $t$ as a function of $\cos\theta$: \begin{equation} t = -2\bar x \left(E^2 - p\bar p\cos\theta\right) + s + u. \end{equation} Solving for $\cos\theta$, we get \begin{equation} \cos\theta = \frac{2\bar x E^2 + t - s - u}{2\bar x p\bar p}. \end{equation} We can compute $\sin\theta$ numerically as $\sin^2\theta=1-\cos^2\theta$, but it is important to reexpress this in view of numerical stability. To this end, we first determine the bounds for $t$. The cosine must be between $-1$ and $1$, so the bounds are \begin{align} t_0 &= -2\bar x\left(E^2 + p\bar p\right) + s + u, \\ t_1 &= -2\bar x\left(E^2 - p\bar p\right) + s + u. \end{align} Computing $\sin^2\theta$ from $\cos\theta$ above, we observe that the numerator is a quadratic polynomial in $t$ which has the zeros $t_0$ and $t_1$, while the common denominator is given by $(2\bar x p\bar p)^2$. Hence, we can write \begin{equation} \sin^2\theta = -\frac{(t - t_0)(t - t_1)}{(2\bar x p\bar p)^2} \qquad\text{and}\qquad \cos\theta = \frac{(t-t_0) + (t-t_1)}{4\bar x p\bar p}, \end{equation} which is free of large cancellations near $t=t_0$ or $t=t_1$. If all is massless, i.e., $s=u=0$, this simplifies to \begin{align} t_0 &= -4\bar x E^2, & t_1 &= 0, \\ \sin^2\theta &= -\frac{t}{\bar x E^2} \left(1 + \frac{t}{4\bar x E^2}\right), & \cos\theta &= 1 + \frac{t}{2\bar x E^2}. \end{align} Here is the implementation. First, we define a container for the kinematical integration limits and some further data. Note: contents are public only for easy access in unit test. <>= public :: splitting_data_t <>= type :: splitting_data_t ! private logical :: collinear = .false. real(default) :: x0 = 0 real(default) :: x1 real(default) :: t0 real(default) :: t1 real(default) :: phi0 = 0 real(default) :: phi1 = twopi real(default) :: E, p, s, u, m2 real(default) :: x, xb, pb real(default) :: t = 0 real(default) :: phi = 0 contains <> end type splitting_data_t @ %def splitting_data_t @ I/O for debugging: <>= procedure :: write => splitting_data_write <>= subroutine splitting_data_write (d, unit) class(splitting_data_t), intent(in) :: d integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "Splitting data:" write (u, "(2x,A,L1)") "collinear = ", d%collinear 1 format (2x,A,1x,ES15.8) write (u, 1) "x0 =", d%x0 write (u, 1) "x =", d%x write (u, 1) "xb =", d%xb write (u, 1) "x1 =", d%x1 write (u, 1) "t0 =", d%t0 write (u, 1) "t =", d%t write (u, 1) "t1 =", d%t1 write (u, 1) "phi0 =", d%phi0 write (u, 1) "phi =", d%phi write (u, 1) "phi1 =", d%phi1 write (u, 1) "E =", d%E write (u, 1) "p =", d%p write (u, 1) "pb =", d%pb write (u, 1) "s =", d%s write (u, 1) "u =", d%u write (u, 1) "m2 =", d%m2 end subroutine splitting_data_write @ %def splitting_data_write @ \subsection{Constant data} This is the initializer for the data. The input consists of the incoming momentum, its invariant mass squared, and the invariant mass squared of the radiated particle. $m2$ is the \emph{physical} mass squared of the outgoing particle. The $t$ bounds depend on the chosen $x$ value and cannot be determined yet. <>= procedure :: init => splitting_data_init <>= subroutine splitting_data_init (d, k, mk2, mr2, mo2, collinear) class(splitting_data_t), intent(out) :: d type(vector4_t), intent(in) :: k real(default), intent(in) :: mk2, mr2, mo2 logical, intent(in), optional :: collinear if (present (collinear)) d%collinear = collinear d%E = energy (k) d%x1 = 1 - sqrt (max (mr2, 0._default)) / d%E d%p = sqrt (d%E**2 - mk2) d%s = mk2 d%u = mr2 d%m2 = mo2 end subroutine splitting_data_init @ %def splitting_data_init @ Retrieve the $x$ bounds, if needed for $x$ sampling. Generating an $x$ value is done by the caller, since this is the part that depends on the nature of the structure function. <>= procedure :: get_x_bounds => splitting_get_x_bounds <>= function splitting_get_x_bounds (d) result (x) class(splitting_data_t), intent(in) :: d real(default), dimension(2) :: x x = [ d%x0, d%x1 ] end function splitting_get_x_bounds @ %def splitting_get_x_bounds @ Now set the momentum fraction and compute $t_0$ and $t_1$. [The calculation of $t_1$ is subject to numerical problems. The exact formula is ($s=m_i^2$, $u=m_r^2$) \begin{equation} t_1 = -2\bar x E^2 + m_i^2 + m_r^2 + 2\bar x \sqrt{E^2-m_i^2}\,\sqrt{E^2 - m_r^2/\bar x^2}. \end{equation} The structure-function paradigm is useful only if $E\gg m_i,m_r$. In a Taylor expansion for large $E$, the leading term cancels. The expansion of the square roots (to subleading order) yields \begin{equation} t_1 = xm_i^2 - \frac{x}{\bar x}m_r^2. \end{equation} There are two cases of interest: $m_i=m_o$ and $m_r=0$, \begin{equation} t_1 = xm_o^2 \end{equation} and $m_i=m_r$ and $m_o=0$, \begin{equation} t_1 = -\frac{x^2}{\bar x}m_i^2. \end{equation} In both cases, $t_1\leq m_o^2$.] That said, it turns out that taking the $t_1$ evaluation at face value leads to less problems than the approximation. We express the angles in terms of $t-t_0$ and $t-t_1$. Numerical noise in $t_1$ can then be tolerated. <>= procedure :: set_t_bounds => splitting_set_t_bounds <>= elemental subroutine splitting_set_t_bounds (d, x, xb) class(splitting_data_t), intent(inout) :: d real(default), intent(in), optional :: x, xb real(default) :: tp, tm if (present (x)) d%x = x if (present (xb)) d%xb = xb if (vanishes (d%u)) then d%pb = d%E else if (.not. vanishes (d%xb)) then d%pb = sqrt (max (d%E**2 - d%u / d%xb**2, 0._default)) else d%pb = 0 end if end if tp = -2 * d%xb * d%E**2 + d%s + d%u tm = -2 * d%xb * d%p * d%pb d%t0 = tp + tm d%t1 = tp - tm d%t = d%t1 end subroutine splitting_set_t_bounds @ %def splitting_set_t_bounds @ \subsection{Sampling recoil} Compute a value for the momentum transfer $t$, using a random number $r$. We assume a logarithmic distribution for $t-m^2$, corresponding to the propagator $1/(t-m^2)$ with the physical mass $m$ for the outgoing particle. Optionally, we can narrow the kinematical bounds. If all three masses in the splitting vanish, the upper limit for $t$ is zero. In that case, the $t$ value is set to zero and the splitting will be collinear. <>= procedure :: sample_t => splitting_sample_t <>= subroutine splitting_sample_t (d, r, t0, t1) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r real(default), intent(in), optional :: t0, t1 real(default) :: tt0, tt1, tt0m, tt1m if (d%collinear) then d%t = d%t1 else tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0) tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1) tt0m = tt0 - d%m2 tt1m = tt1 - d%m2 if (tt0m < 0 .and. tt1m < 0 .and. abs(tt0m) > & epsilon(tt0m) .and. abs(tt1m) > epsilon(tt0m)) then d%t = d%m2 + tt0m * exp (r * log (tt1m / tt0m)) else d%t = tt1 end if end if end subroutine splitting_sample_t @ %def splitting_sample_t @ The inverse operation: Given $t$, we recover the value of $r$ that would have produced this value. <>= procedure :: inverse_t => splitting_inverse_t <>= subroutine splitting_inverse_t (d, r, t0, t1) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r real(default), intent(in), optional :: t0, t1 real(default) :: tt0, tt1, tt0m, tt1m if (d%collinear) then r = 0 else tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0) tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1) tt0m = tt0 - d%m2 tt1m = tt1 - d%m2 if (tt0m < 0 .and. tt1m < 0) then r = log ((d%t - d%m2) / tt0m) / log (tt1m / tt0m) else r = 0 end if end if end subroutine splitting_inverse_t @ %def splitting_inverse_t @ This is trivial, but provided for convenience: <>= procedure :: sample_phi => splitting_sample_phi <>= subroutine splitting_sample_phi (d, r) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r if (d%collinear) then d%phi = 0 else d%phi = (1-r) * d%phi0 + r * d%phi1 end if end subroutine splitting_sample_phi @ %def splitting_sample_phi @ Inverse: <>= procedure :: inverse_phi => splitting_inverse_phi <>= subroutine splitting_inverse_phi (d, r) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r if (d%collinear) then r = 0 else r = (d%phi - d%phi0) / (d%phi1 - d%phi0) end if end subroutine splitting_inverse_phi @ %def splitting_inverse_phi @ \subsection{Splitting} In this function, we actually perform the splitting. The incoming momentum $k$ is split into (if no recoil) $q_1=(1-x)k$ and $q_2=xk$. Apart from the splitting data, we need the incoming momentum $k$, the momentum transfer $t$, and the azimuthal angle $\phi$. The momentum fraction $x$ is already known here. Alternatively, we can split without recoil. The azimuthal angle is irrelevant, and the momentum transfer is always equal to the upper limit $t_1$, so the polar angle is zero. Obviously, if there are nonzero masses it is not possible to keep both energy-momentum conservation and at the same time all particles on shell. We choose for dropping the on-shell condition here. <>= procedure :: split_momentum => splitting_split_momentum <>= function splitting_split_momentum (d, k) result (q) class(splitting_data_t), intent(in) :: d type(vector4_t), dimension(2) :: q type(vector4_t), intent(in) :: k real(default) :: st2, ct2, st, ct, cp, sp type(lorentz_transformation_t) :: rot real(default) :: tt0, tt1, den type(vector3_t) :: kk, q1, q2 if (d%collinear) then if (vanishes (d%s) .and. vanishes(d%u)) then q(1) = d%xb * k q(2) = d%x * k else kk = space_part (k) q1 = d%xb * (d%pb / d%p) * kk q2 = kk - q1 q(1) = vector4_moving (d%xb * d%E, q1) q(2) = vector4_moving (d%x * d%E, q2) end if else den = 2 * d%xb * d%p * d%pb tt0 = max (d%t - d%t0, 0._default) tt1 = min (d%t - d%t1, 0._default) if (den**2 <= epsilon(den)) then st2 = 0 else st2 = - (tt0 * tt1) / den ** 2 end if if (st2 > 1) then st2 = 1 end if ct2 = 1 - st2 st = sqrt (max (st2, 0._default)) ct = sqrt (max (ct2, 0._default)) if ((d%t - d%t0 + d%t - d%t1) < 0) then ct = - ct end if sp = sin (d%phi) cp = cos (d%phi) rot = rotation_to_2nd (3, space_part (k)) q1 = vector3_moving (d%xb * d%pb * [st * cp, st * sp, ct]) q2 = vector3_moving (d%p, 3) - q1 q(1) = rot * vector4_moving (d%xb * d%E, q1) q(2) = rot * vector4_moving (d%x * d%E, q2) end if end function splitting_split_momentum @ %def splitting_split_momentum @ Momenta generated by splitting will in general be off-shell. They are on-shell only if they are collinear and massless. This subroutine puts them on shell by brute force, violating either momentum or energy conservation. The direction of three-momentum is always retained. If the energy is below mass shell, we return a zero momentum. <>= integer, parameter, public :: KEEP_ENERGY = 0, KEEP_MOMENTUM = 1 @ %def KEEP_ENERGY KEEP_MOMENTUM <>= public :: on_shell <>= elemental subroutine on_shell (p, m2, keep) type(vector4_t), intent(inout) :: p real(default), intent(in) :: m2 integer, intent(in) :: keep real(default) :: E, E2, pn select case (keep) case (KEEP_ENERGY) E = energy (p) E2 = E ** 2 if (E2 >= m2) then pn = sqrt (E2 - m2) p = vector4_moving (E, pn * direction (space_part (p))) else p = vector4_null end if case (KEEP_MOMENTUM) E = sqrt (space_part (p) ** 2 + m2) p = vector4_moving (E, space_part (p)) end select end subroutine on_shell @ %def on_shell @ \subsection{Recovering the splitting} This is the inverse problem. We have on-shell momenta and want to deduce the splitting parameters $x$, $t$, and $\phi$. Update 2018-08-22: As a true inverse to [[splitting_split_momentum]], we now use not just a single momentum [[q2]] as before, but the momentum pair [[q1]], [[q2]] for recovering $x$ and $\bar x$ separately. If $x$ happens to be close to $1$, we would completely lose the tiny $\bar x$ value, otherwise, and thus get a meaningless result. <>= procedure :: recover => splitting_recover <>= subroutine splitting_recover (d, k, q, keep) class(splitting_data_t), intent(inout) :: d type(vector4_t), intent(in) :: k type(vector4_t), dimension(2), intent(in) :: q integer, intent(in) :: keep type(lorentz_transformation_t) :: rot type(vector4_t) :: k0 type(vector4_t), dimension(2) :: q0 real(default) :: p1, p2, p3, pt2, pp2, pl real(default) :: aux, den, norm real(default) :: st2, ct2, ct rot = inverse (rotation_to_2nd (3, space_part (k))) q0 = rot * q p1 = vector4_get_component (q0(2), 1) p2 = vector4_get_component (q0(2), 2) p3 = vector4_get_component (q0(2), 3) pt2 = p1 ** 2 + p2 ** 2 pp2 = p1 ** 2 + p2 ** 2 + p3 ** 2 pl = abs (p3) k0 = vector4_moving (d%E, d%p, 3) select case (keep) case (KEEP_ENERGY) d%x = energy (q0(2)) / d%E d%xb = energy (q0(1)) / d%E call d%set_t_bounds () if (.not. d%collinear) then aux = (d%xb * d%pb) ** 2 * pp2 - d%p ** 2 * pt2 den = d%p ** 2 - (d%xb * d%pb) ** 2 if (aux >= 0 .and. den > 0) then norm = (d%p * pl + sqrt (aux)) / den else norm = 1 end if end if case (KEEP_MOMENTUM) d%xb = sqrt (space_part (q0(1)) ** 2 + d%u) / d%E d%x = 1 - d%xb call d%set_t_bounds () norm = 1 end select if (d%collinear) then d%t = d%t1 d%phi = 0 else if ((d%xb * d%pb * norm)**2 < epsilon(d%xb)) then st2 = 1 else st2 = pt2 / (d%xb * d%pb * norm ) ** 2 end if if (st2 > 1) then st2 = 1 end if ct2 = 1 - st2 ct = sqrt (max (ct2, 0._default)) if (.not. vanishes (1 + ct)) then d%t = d%t1 - 2 * d%xb * d%p * d%pb * st2 / (1 + ct) else d%t = d%t0 end if if (.not. vanishes (p1) .or. .not. vanishes (p2)) then d%phi = atan2 (-p2, -p1) else d%phi = 0 end if end if end subroutine splitting_recover @ %def splitting_recover @ \subsection{Extract data} <>= procedure :: get_x => splitting_get_x procedure :: get_xb => splitting_get_xb <>= function splitting_get_x (sd) result (x) class(splitting_data_t), intent(in) :: sd real(default) :: x x = sd%x end function splitting_get_x function splitting_get_xb (sd) result (xb) class(splitting_data_t), intent(in) :: sd real(default) :: xb xb = sd%xb end function splitting_get_xb @ %def splitting_get_x @ %def splitting_get_xb @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_aux_ut.f90]]>>= <> module sf_aux_ut use unit_tests use sf_aux_uti <> <> contains <> end module sf_aux_ut @ %def sf_aux_ut @ <<[[sf_aux_uti.f90]]>>= <> module sf_aux_uti <> + use numeric_utils, only: pacify use lorentz use sf_aux <> <> contains <> end module sf_aux_uti @ %def sf_aux_ut @ API: driver for the unit tests below. <>= public :: sf_aux_test <>= subroutine sf_aux_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_aux_test @ %def sf_aux_test @ \subsubsection{Momentum splitting: massless radiation} Compute momentum splitting for generic kinematics. It turns out that for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and lower bounds (this can be directly seen from the logarithmic distribution in the function [[sample_t]] for $r \equiv x = 1 - x = 0.5$), we arrive at an exact number $t=-0.15$ for the given input values. <>= call test (sf_aux_1, "sf_aux_1", & "massless radiation", & u, results) <>= public :: sf_aux_1 <>= subroutine sf_aux_1 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q0_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_1" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (massless radiated particle)" write (u, "(A)") E = 1 mk = 0.3_default mp = 0 mq = mk k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "Extract: x, 1-x" write (u, "(2(1x,F11.8))") sd%get_x (), sd%get_xb () write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_1" end subroutine sf_aux_1 @ %def sf_aux_1 @ \subsubsection{Momentum splitting: massless parton} Compute momentum splitting for generic kinematics. It turns out that for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and lower bounds, we arrive at an exact number $t=-0.36$ for the given input values. <>= call test (sf_aux_2, "sf_aux_2", & "massless parton", & u, results) <>= public :: sf_aux_2 <>= subroutine sf_aux_2 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q02_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_2" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (massless outgoing particle)" write (u, "(A)") E = 1 mk = 0.3_default mp = mk mq = 0 k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_2" end subroutine sf_aux_2 @ %def sf_aux_2 @ \subsubsection{Momentum splitting: all massless} Compute momentum splitting for massless kinematics. In the non-collinear case, we need a lower cutoff for $|t|$, otherwise a logarithmic distribution is not possible. <>= call test (sf_aux_3, "sf_aux_3", & "massless parton", & u, results) <>= public :: sf_aux_3 <>= subroutine sf_aux_3 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq, qmin, qmax real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q02_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_3" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (all massless, q cuts)" write (u, "(A)") E = 1 mk = 0 mp = 0 mq = 0 qmin = 1e-2_default qmax = 1e0_default k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1, t1 = - qmin ** 2, t0 = - qmax **2) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_3" end subroutine sf_aux_3 @ %def sf_aux_3 @ \subsubsection{Endpoint stability} Compute momentum splitting for collinear kinematics close to both endpoints. In particular, check both directions $x\to$ momenta and momenta $\to x$. For purely massless collinear splitting, the [[KEEP_XXX]] flag is irrelevant. We choose [[KEEP_ENERGY]] here. <>= call test (sf_aux_4, "sf_aux_4", & "endpoint numerics", & u, results) <>= public :: sf_aux_4 <>= subroutine sf_aux_4 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E, mk, mp, mq, qmin, qmax real(default) :: x, xb write (u, "(A)") "* Test output: sf_aux_4" write (u, "(A)") "* Purpose: compute massless collinear splitting near endpoint" E = 1 mk = 0 mp = 0 mq = 0 qmin = 1e-2_default qmax = 1e0_default k = vector4_moving (E, sqrt (E**2 - mk**2), 3) x = 0.1_default xb = 1 - x write (u, "(A)") write (u, "(A)") "* (1) Collinear setup, moderate kinematics" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Close to x=0" write (u, "(A)") x = 1e-9_default xb = 1 - x call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (3) Close to x=1" write (u, "(A)") xb = 1e-9_default x = 1 - xb call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_4" end subroutine sf_aux_4 @ %def sf_aux_4 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Mappings for structure functions} In this module, we provide a wrapper for useful mappings of the unit (hyper-)square that we can apply to a set of structure functions. In some cases it is useful, or even mandatory, to map the MC input parameters nontrivially onto a set of structure functions for the two beams. In all cases considered here, instead of $x_1,x_2,\ldots$ as parameters for the beams, we generate one parameter that is equal, or related to, the product $x_1x_2\cdots$ (so it directly corresponds to $\sqrt{s}$). The other parameters describe the distribution of energy (loss) between beams and radiations. <<[[sf_mappings.f90]]>>= <> module sf_mappings <> use kinds, only: double use io_units use constants, only: pi, zero, one use numeric_utils use diagnostics <> <> <> <> <> contains <> end module sf_mappings @ %def sf_mappings @ \subsection{Base type} First, we define an abstract base type for the mapping. In all cases we need to store the indices of the parameters on which the mapping applies. Additional parameters can be stored in the extensions of this type. <>= public :: sf_mapping_t <>= type, abstract :: sf_mapping_t integer, dimension(:), allocatable :: i contains <> end type sf_mapping_t @ %def sf_mapping_t @ The output routine is deferred: <>= procedure (sf_mapping_write), deferred :: write <>= abstract interface subroutine sf_mapping_write (object, unit) import class(sf_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_mapping_write end interface @ %def sf_mapping_write @ Initializer for the base type. The array of parameter indices is allocated but initialized to zero. <>= procedure :: base_init => sf_mapping_base_init <>= subroutine sf_mapping_base_init (mapping, n_par) class(sf_mapping_t), intent(out) :: mapping integer, intent(in) :: n_par allocate (mapping%i (n_par)) mapping%i = 0 end subroutine sf_mapping_base_init @ %def sf_mapping_base_init @ Set an index value. <>= procedure :: set_index => sf_mapping_set_index <>= subroutine sf_mapping_set_index (mapping, j, i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i end subroutine sf_mapping_set_index @ %def sf_mapping_set_index @ Retrieve an index value. <>= procedure :: get_index => sf_mapping_get_index <>= function sf_mapping_get_index (mapping, j) result (i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j integer :: i i = mapping%i(j) end function sf_mapping_get_index @ %def sf_mapping_get_index @ Return the dimensionality, i.e., the number of parameters. <>= procedure :: get_n_dim => sf_mapping_get_n_dim <>= function sf_mapping_get_n_dim (mapping) result (n) class(sf_mapping_t), intent(in) :: mapping integer :: n n = size (mapping%i) end function sf_mapping_get_n_dim @ %def sf_mapping_get_n_dim @ Computation: the values [[p]] are the input parameters, the values [[r]] are the output parameters. The values [[rb]] are defined as $\bar r = 1 - r$, but provided explicitly. They allow us to avoid numerical problems near $r=1$. The extra parameter [[x_free]] indicates that the total energy has already been renormalized by this factor. We have to take such a factor into account in a resonance or on-shell mapping. The Jacobian is [[f]]. We modify only the two parameters indicated by the indices [[i]]. <>= procedure (sf_mapping_compute), deferred :: compute <>= abstract interface subroutine sf_mapping_compute (mapping, r, rb, f, p, pb, x_free) import class(sf_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_mapping_compute end interface @ %def sf_mapping_compute @ The inverse mapping. Use [[r]] and/or [[rb]] to reconstruct [[p]] and also compute [[f]]. <>= procedure (sf_mapping_inverse), deferred :: inverse <>= abstract interface subroutine sf_mapping_inverse (mapping, r, rb, f, p, pb, x_free) import class(sf_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_mapping_inverse end interface @ %def sf_mapping_inverse @ \subsection{Methods for self-tests} This is a shorthand for: inject parameters, compute the mapping, display results, compute the inverse, display again. We provide an output format for the parameters and, optionally, a different output format for the Jacobians. <>= procedure :: check => sf_mapping_check <>= subroutine sf_mapping_check (mapping, u, p_in, pb_in, fmt_p, fmt_f) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: u real(default), dimension(:), intent(in) :: p_in, pb_in character(*), intent(in) :: fmt_p character(*), intent(in), optional :: fmt_f real(default), dimension(size(p_in)) :: p, pb, r, rb real(default) :: f, tolerance tolerance = 1.5E-17 p = p_in pb= pb_in call mapping%compute (r, rb, f, p, pb) call pacify (p, tolerance) call pacify (pb, tolerance) call pacify (r, tolerance) call pacify (rb, tolerance) write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb if (present (fmt_f)) then write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f else write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f end if write (u, *) call mapping%inverse (r, rb, f, p, pb) call pacify (p, tolerance) call pacify (pb, tolerance) call pacify (r, tolerance) call pacify (rb, tolerance) write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb if (present (fmt_f)) then write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f else write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f end if write (u, *) write (u, "(3x,A,9(1x," // fmt_p // "))") "*r=", product (r) end subroutine sf_mapping_check @ %def sf_mapping_check @ This is a consistency check for the self-tests: the integral over the unit square should be unity. We estimate this by a simple binning and adding up the values; this should be sufficient for a self-test. The argument is the requested number of sampling points. We take the square root for binning in both dimensions, so the precise number might be different. <>= procedure :: integral => sf_mapping_integral <>= function sf_mapping_integral (mapping, n_calls) result (integral) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: n_calls real(default) :: integral integer :: n_dim, n_bin, k real(default), dimension(:), allocatable :: p, pb, r, rb integer, dimension(:), allocatable :: ii real(default) :: dx, f, s n_dim = mapping%get_n_dim () allocate (p (n_dim)) allocate (pb(n_dim)) allocate (r (n_dim)) allocate (rb(n_dim)) allocate (ii(n_dim)) n_bin = nint (real (n_calls, default) ** (1._default / n_dim)) dx = 1._default / n_bin s = 0 ii = 1 SAMPLE: do do k = 1, n_dim p(k) = ii(k) * dx - dx/2 pb(k) = (n_bin - ii(k)) * dx + dx/2 end do call mapping%compute (r, rb, f, p, pb) s = s + f INCR: do k = 1, n_dim ii(k) = ii(k) + 1 if (ii(k) <= n_bin) then exit INCR else if (k < n_dim) then ii(k) = 1 else exit SAMPLE end if end do INCR end do SAMPLE integral = s / real (n_bin, default) ** n_dim end function sf_mapping_integral @ %def sf_mapping_integral @ \subsection{Implementation: standard mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. <>= public :: sf_s_mapping_t <>= type, extends (sf_mapping_t) :: sf_s_mapping_t logical :: power_set = .false. real(default) :: power = 1 contains <> end type sf_s_mapping_t @ %def sf_s_mapping_t @ Output. <>= procedure :: write => sf_s_mapping_write <>= subroutine sf_s_mapping_write (object, unit) class(sf_s_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": standard (", object%power, ")" end subroutine sf_s_mapping_write @ %def sf_s_mapping_write @ Initialize: index pair and power parameter. <>= procedure :: init => sf_s_mapping_init <>= subroutine sf_s_mapping_init (mapping, power) class(sf_s_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: power call mapping%base_init (2) if (present (power)) then mapping%power_set = .true. mapping%power = power end if end subroutine sf_s_mapping_init @ %def sf_s_mapping_init @ Apply mapping. <>= procedure :: compute => sf_s_mapping_compute <>= subroutine sf_s_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2 integer :: j if (mapping%power_set) then call map_unit_square (r2, f, p(mapping%i), mapping%power) else call map_unit_square (r2, f, p(mapping%i)) end if r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_s_mapping_compute @ %def sf_s_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_s_mapping_inverse <>= subroutine sf_s_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2 integer :: j if (mapping%power_set) then call map_unit_square_inverse (r(mapping%i), f, p2, mapping%power) else call map_unit_square_inverse (r(mapping%i), f, p2) end if p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_s_mapping_inverse @ %def sf_s_mapping_inverse @ \subsection{Implementation: resonance pair mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio, then it maps $p_1$ to itself according to a Breit-Wigner shape, i.e., a flat prior distribution in $p_1$ results in a Breit-Wigner distribution. Mass and width of the BW are rescaled by the energy, thus dimensionless fractions. <>= public :: sf_res_mapping_t <>= type, extends (sf_mapping_t) :: sf_res_mapping_t real(default) :: m = 0 real(default) :: w = 0 contains <> end type sf_res_mapping_t @ %def sf_res_mapping_t @ Output. <>= procedure :: write => sf_res_mapping_write <>= subroutine sf_res_mapping_write (object, unit) class(sf_res_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")" end subroutine sf_res_mapping_write @ %def sf_res_mapping_write @ Initialize: index pair and dimensionless mass and width parameters. <>= procedure :: init => sf_res_mapping_init <>= subroutine sf_res_mapping_init (mapping, m, w) class(sf_res_mapping_t), intent(out) :: mapping real(default), intent(in) :: m, w call mapping%base_init (2) mapping%m = m mapping%w = w end subroutine sf_res_mapping_init @ %def sf_res_mapping_init @ Apply mapping. <>= procedure :: compute => sf_res_mapping_compute <>= subroutine sf_res_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, p2 real(default) :: fbw, f2, p1m integer :: j p2 = p(mapping%i) call map_breit_wigner & (p1m, fbw, p2(1), mapping%m, mapping%w, x_free) call map_unit_square (r2, f2, [p1m, p2(2)]) f = fbw * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_res_mapping_compute @ %def sf_res_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_res_mapping_inverse <>= subroutine sf_res_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2 real(default) :: fbw, f2, p1m call map_unit_square_inverse (r(mapping%i), f2, p2) call map_breit_wigner_inverse & (p2(1), fbw, p1m, mapping%m, mapping%w, x_free) p = r pb= rb p (mapping%i(1)) = p1m pb(mapping%i(1)) = 1 - p1m p (mapping%i(2)) = p2(2) pb(mapping%i(2)) = 1 - p2(2) f = fbw * f2 end subroutine sf_res_mapping_inverse @ %def sf_res_mapping_inverse @ \subsection{Implementation: resonance single mapping} While simpler, this is needed for structure-function setups only in exceptional cases. This maps the unit interval ($r_1$) to itself according to a Breit-Wigner shape, i.e., a flat prior distribution in $r_1$ results in a Breit-Wigner distribution. Mass and width of the BW are rescaled by the energy, thus dimensionless fractions. <>= public :: sf_res_mapping_single_t <>= type, extends (sf_mapping_t) :: sf_res_mapping_single_t real(default) :: m = 0 real(default) :: w = 0 contains <> end type sf_res_mapping_single_t @ %def sf_res_mapping_single_t @ Output. <>= procedure :: write => sf_res_mapping_single_write <>= subroutine sf_res_mapping_single_write (object, unit) class(sf_res_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")" end subroutine sf_res_mapping_single_write @ %def sf_res_mapping_single_write @ Initialize: single index (!) and dimensionless mass and width parameters. <>= procedure :: init => sf_res_mapping_single_init <>= subroutine sf_res_mapping_single_init (mapping, m, w) class(sf_res_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m, w call mapping%base_init (1) mapping%m = m mapping%w = w end subroutine sf_res_mapping_single_init @ %def sf_res_mapping_single_init @ Apply mapping. <>= procedure :: compute => sf_res_mapping_single_compute <>= subroutine sf_res_mapping_single_compute (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: r2, p2 real(default) :: fbw integer :: j p2 = p(mapping%i) call map_breit_wigner & (r2(1), fbw, p2(1), mapping%m, mapping%w, x_free) f = fbw r = p rb= pb r (mapping%i(1)) = r2(1) rb(mapping%i(1)) = 1 - r2(1) end subroutine sf_res_mapping_single_compute @ %def sf_res_mapping_single_compute @ Apply inverse. <>= procedure :: inverse => sf_res_mapping_single_inverse <>= subroutine sf_res_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: p2 real(default) :: fbw call map_breit_wigner_inverse & (r(mapping%i(1)), fbw, p2(1), mapping%m, mapping%w, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) f = fbw end subroutine sf_res_mapping_single_inverse @ %def sf_res_mapping_single_inverse @ \subsection{Implementation: on-shell mapping} This is a degenerate version of the unit-square mapping where the product $r_1r_2$ is constant. This product is given by the rescaled squared mass. We introduce an artificial first parameter $p_1$ to keep the counting, but nothing depends on it. The second parameter is the same $p_2$ as for the standard unit-square mapping for $\alpha=1$, it parameterizes the ratio of $r_1$ and $r_2$. <>= public :: sf_os_mapping_t <>= type, extends (sf_mapping_t) :: sf_os_mapping_t real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_os_mapping_t @ %def sf_os_mapping_t @ Output. <>= procedure :: write => sf_os_mapping_write <>= subroutine sf_os_mapping_write (object, unit) class(sf_os_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")" end subroutine sf_os_mapping_write @ %def sf_os_mapping_write @ Initialize: index pair and dimensionless mass parameter. <>= procedure :: init => sf_os_mapping_init <>= subroutine sf_os_mapping_init (mapping, m) class(sf_os_mapping_t), intent(out) :: mapping real(default), intent(in) :: m call mapping%base_init (2) mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_os_mapping_init @ %def sf_os_mapping_init @ Apply mapping. The [[x_free]] parameter rescales the total energy, which must be accounted for in the enclosed mapping. <>= procedure :: compute => sf_os_mapping_compute <>= subroutine sf_os_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, p2 integer :: j p2 = p(mapping%i) call map_on_shell (r2, f, p2, mapping%lm2, x_free) r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_os_mapping_compute @ %def sf_os_mapping_compute @ Apply inverse. The irrelevant parameter $p_1$ is always set zero. <>= procedure :: inverse => sf_os_mapping_inverse <>= subroutine sf_os_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2, r2 r2 = r(mapping%i) call map_on_shell_inverse (r2, f, p2, mapping%lm2, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) p (mapping%i(2)) = p2(2) pb(mapping%i(2)) = 1 - p2(2) end subroutine sf_os_mapping_inverse @ %def sf_os_mapping_inverse @ \subsection{Implementation: on-shell single mapping} This is a degenerate version of the unit-interval mapping where the result $r$ is constant. The value is given by the rescaled squared mass. The input parameter $p_1$ is actually ignored, nothing depends on it. <>= public :: sf_os_mapping_single_t <>= type, extends (sf_mapping_t) :: sf_os_mapping_single_t real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_os_mapping_single_t @ %def sf_os_mapping_single_t @ Output. <>= procedure :: write => sf_os_mapping_single_write <>= subroutine sf_os_mapping_single_write (object, unit) class(sf_os_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")" end subroutine sf_os_mapping_single_write @ %def sf_os_mapping_single_write @ Initialize: index pair and dimensionless mass parameter. <>= procedure :: init => sf_os_mapping_single_init <>= subroutine sf_os_mapping_single_init (mapping, m) class(sf_os_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m call mapping%base_init (1) mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_os_mapping_single_init @ %def sf_os_mapping_single_init @ Apply mapping. The [[x_free]] parameter rescales the total energy, which must be accounted for in the enclosed mapping. <>= procedure :: compute => sf_os_mapping_single_compute <>= subroutine sf_os_mapping_single_compute (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: r2, p2 integer :: j p2 = p(mapping%i) call map_on_shell_single (r2, f, p2, mapping%lm2, x_free) r = p rb= pb r (mapping%i(1)) = r2(1) rb(mapping%i(1)) = 1 - r2(1) end subroutine sf_os_mapping_single_compute @ %def sf_os_mapping_single_compute @ Apply inverse. The irrelevant parameter $p_1$ is always set zero. <>= procedure :: inverse => sf_os_mapping_single_inverse <>= subroutine sf_os_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: p2, r2 r2 = r(mapping%i) call map_on_shell_single_inverse (r2, f, p2, mapping%lm2, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) end subroutine sf_os_mapping_single_inverse @ %def sf_os_mapping_single_inverse @ \subsection{Implementation: endpoint mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that any power-like singularity is caught. This is useful for beamstrahlung spectra. In addition, we allow for a delta-function singularity in $r_1$ and/or $r_2$. The singularity is smeared to an interval of width $\epsilon$. If nonzero, we distinguish the kinematical momentum fractions $r_i$ from effective values $x_i$, which should go into the structure-function evaluation. A bin of width $\epsilon$ in $r$ is mapped to $x=1$ exactly, while the interval $(0,1-\epsilon)$ is mapped to $(0,1)$ in $x$. The Jacobian reflects this distinction, and the logical [[in_peak]] allows for an unambiguous distinction. The delta-peak fraction is used only for the integration self-test. <>= public :: sf_ep_mapping_t <>= type, extends (sf_mapping_t) :: sf_ep_mapping_t real(default) :: a = 1 contains <> end type sf_ep_mapping_t @ %def sf_ep_mapping_t @ Output. <>= procedure :: write => sf_ep_mapping_write <>= subroutine sf_ep_mapping_write (object, unit) class(sf_ep_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,ES12.5,A)") ": endpoint (a =", object%a, ")" end subroutine sf_ep_mapping_write @ %def sf_ep_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ep_mapping_init <>= subroutine sf_ep_mapping_init (mapping, a) class(sf_ep_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a call mapping%base_init (2) if (present (a)) mapping%a = a end subroutine sf_ep_mapping_init @ %def sf_ep_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ep_mapping_compute <>= subroutine sf_ep_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f1, f2 integer :: j call map_endpoint_1 (px(1), f1, p(mapping%i(1)), mapping%a) call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_unit_square (r2, f, px) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_ep_mapping_compute @ %def sf_ep_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ep_mapping_inverse <>= subroutine sf_ep_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, px, p2 real(default) :: f1, f2 integer :: j do j = 1, 2 r2(j) = r(mapping%i(j)) end do call map_unit_square_inverse (r2, f, px) call map_endpoint_inverse_1 (px(1), f1, p2(1), mapping%a) call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_ep_mapping_inverse @ %def sf_ep_mapping_inverse @ \subsection{Implementation: endpoint mapping with resonance} Like the endpoint mapping for $p_2$, but replace the endpoint mapping by a Breit-Wigner mapping for $p_1$. This covers resonance production in the presence of beamstrahlung. If the flag [[resonance]] is unset, we skip the resonance mapping, so the parameter $p_1$ remains equal to $r_1r_2$, as in the standard s-channel mapping. <>= public :: sf_epr_mapping_t <>= type, extends (sf_mapping_t) :: sf_epr_mapping_t real(default) :: a = 1 real(default) :: m = 0 real(default) :: w = 0 logical :: resonance = .true. contains <> end type sf_epr_mapping_t @ %def sf_epr_mapping_t @ Output. <>= procedure :: write => sf_epr_mapping_write <>= subroutine sf_epr_mapping_write (object, unit) class(sf_epr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if if (object%resonance) then write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": ep/res (a = ", object%a, & " | ", object%m, object%w, ")" else write (u, "(A,F7.5,A)") ": ep/nores (a = ", object%a, ")" end if end subroutine sf_epr_mapping_write @ %def sf_epr_mapping_write @ Initialize: if mass and width are not given, we initialize a non-resonant version of the mapping. <>= procedure :: init => sf_epr_mapping_init <>= subroutine sf_epr_mapping_init (mapping, a, m, w) class(sf_epr_mapping_t), intent(out) :: mapping real(default), intent(in) :: a real(default), intent(in), optional :: m, w call mapping%base_init (2) mapping%a = a if (present (m) .and. present (w)) then mapping%m = m mapping%w = w else mapping%resonance = .false. end if end subroutine sf_epr_mapping_init @ %def sf_epr_mapping_init @ Apply mapping. <>= procedure :: compute => sf_epr_mapping_compute <>= subroutine sf_epr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f1, f2 integer :: j if (mapping%resonance) then call map_breit_wigner & (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free) else px(1) = p(mapping%i(1)) f1 = 1 end if call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_unit_square (r2, f, px) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_epr_mapping_compute @ %def sf_epr_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_epr_mapping_inverse <>= subroutine sf_epr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, p2 real(default) :: f1, f2 integer :: j call map_unit_square_inverse (r(mapping%i), f, px) if (mapping%resonance) then call map_breit_wigner_inverse & (px(1), f1, p2(1), mapping%m, mapping%w, x_free) else p2(1) = px(1) f1 = 1 end if call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_epr_mapping_inverse @ %def sf_epr_mapping_inverse @ \subsection{Implementation: endpoint mapping for on-shell particle} Analogous to the resonance mapping, but the $p_1$ input is ignored altogether. This covers on-shell particle production in the presence of beamstrahlung. <>= public :: sf_epo_mapping_t <>= type, extends (sf_mapping_t) :: sf_epo_mapping_t real(default) :: a = 1 real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_epo_mapping_t @ %def sf_epo_mapping_t @ Output. <>= procedure :: write => sf_epo_mapping_write <>= subroutine sf_epo_mapping_write (object, unit) class(sf_epo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A)") ": ep/on-shell (a = ", object%a, & " | ", object%m, ")" end subroutine sf_epo_mapping_write @ %def sf_epo_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_epo_mapping_init <>= subroutine sf_epo_mapping_init (mapping, a, m) class(sf_epo_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, m call mapping%base_init (2) mapping%a = a mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_epo_mapping_init @ %def sf_epo_mapping_init @ Apply mapping. <>= procedure :: compute => sf_epo_mapping_compute <>= subroutine sf_epo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f2 integer :: j px(1) = 0 call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_on_shell (r2, f, px, mapping%lm2) f = f * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_epo_mapping_compute @ %def sf_epo_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_epo_mapping_inverse <>= subroutine sf_epo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, p2 real(default) :: f2 integer :: j call map_on_shell_inverse (r(mapping%i), f, px, mapping%lm2) p2(1) = 0 call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_epo_mapping_inverse @ %def sf_epo_mapping_inverse @ \subsection{Implementation: ISR endpoint mapping} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. <>= public :: sf_ip_mapping_t <>= type, extends (sf_mapping_t) :: sf_ip_mapping_t real(default) :: eps = 0 contains <> end type sf_ip_mapping_t @ %def sf_ip_mapping_t @ Output. <>= procedure :: write => sf_ip_mapping_write <>= subroutine sf_ip_mapping_write (object, unit) class(sf_ip_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,ES12.5,A)") ": isr (eps =", object%eps, ")" end subroutine sf_ip_mapping_write @ %def sf_ip_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ip_mapping_init <>= subroutine sf_ip_mapping_init (mapping, eps) class(sf_ip_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") end subroutine sf_ip_mapping_init @ %def sf_ip_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ip_mapping_compute <>= subroutine sf_ip_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, xb, y, yb integer :: j call map_power_1 (xb, f1, pb(mapping%i(1)), 2 * mapping%eps) call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) px(1) = 1 - xb pxb(1) = xb px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f, px, pxb) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ip_mapping_compute @ %def sf_ip_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ip_mapping_inverse <>= subroutine sf_ip_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, xb, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f, px, pxb) xb = pxb(1) if (px(1) > 0) then y = px(2) yb = pxb(2) else y = 0.5_default yb = 0.5_default end if call map_power_inverse_1 (xb, f1, p2b(1), 2 * mapping%eps) call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2 = 1 - p2b f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ip_mapping_inverse @ %def sf_ip_mapping_inverse @ \subsection{Implementation: ISR endpoint mapping, resonant} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. The resonance can be turned off by the flag [[resonance]]. <>= public :: sf_ipr_mapping_t <>= type, extends (sf_mapping_t) :: sf_ipr_mapping_t real(default) :: eps = 0 real(default) :: m = 0 real(default) :: w = 0 logical :: resonance = .true. contains <> end type sf_ipr_mapping_t @ %def sf_ipr_mapping_t @ Output. <>= procedure :: write => sf_ipr_mapping_write <>= subroutine sf_ipr_mapping_write (object, unit) class(sf_ipr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if if (object%resonance) then write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": isr/res (eps = ", & object%eps, " | ", object%m, object%w, ")" else write (u, "(A,F7.5,A)") ": isr/res (eps = ", object%eps, ")" end if end subroutine sf_ipr_mapping_write @ %def sf_ipr_mapping_write @ Initialize: <>= procedure :: init => sf_ipr_mapping_init <>= subroutine sf_ipr_mapping_init (mapping, eps, m, w) class(sf_ipr_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m, w call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") if (present (m) .and. present (w)) then mapping%m = m mapping%w = w else mapping%resonance = .false. end if end subroutine sf_ipr_mapping_init @ %def sf_ipr_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ipr_mapping_compute <>= subroutine sf_ipr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, y, yb integer :: j if (mapping%resonance) then call map_breit_wigner & (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free) else px(1) = p(mapping%i(1)) f1 = 1 end if call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) pxb(1) = 1 - px(1) px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f, px, pxb) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ipr_mapping_compute @ %def sf_ipr_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ipr_mapping_inverse <>= subroutine sf_ipr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f, px, pxb) if (px(1) > 0) then y = px(2) yb = pxb(2) else y = 0.5_default yb = 0.5_default end if if (mapping%resonance) then call map_breit_wigner_inverse & (px(1), f1, p2(1), mapping%m, mapping%w, x_free) else p2(1) = px(1) f1 = 1 end if call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2b(1) = 1 - p2(1) p2 (2) = 1 - p2b(2) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ipr_mapping_inverse @ %def sf_ipr_mapping_inverse @ \subsection{Implementation: ISR on-shell mapping} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is ignored while the product $r_1r_2$ is constant. $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. <>= public :: sf_ipo_mapping_t <>= type, extends (sf_mapping_t) :: sf_ipo_mapping_t real(default) :: eps = 0 real(default) :: m = 0 contains <> end type sf_ipo_mapping_t @ %def sf_ipo_mapping_t @ Output. <>= procedure :: write => sf_ipo_mapping_write <>= subroutine sf_ipo_mapping_write (object, unit) class(sf_ipo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A)") ": isr/os (eps = ", object%eps, & " | ", object%m, ")" end subroutine sf_ipo_mapping_write @ %def sf_ipo_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ipo_mapping_init <>= subroutine sf_ipo_mapping_init (mapping, eps, m) class(sf_ipo_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") mapping%m = m end subroutine sf_ipo_mapping_init @ %def sf_ipo_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ipo_mapping_compute <>= subroutine sf_ipo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, y, yb integer :: j call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) px(1) = mapping%m ** 2 if (present (x_free)) px(1) = px(1) / x_free pxb(1) = 1 - px(1) px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f1, px, pxb) f = f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ipo_mapping_compute @ %def sf_ipo_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ipo_mapping_inverse <>= subroutine sf_ipo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f1, px, pxb) y = px(2) yb = pxb(2) call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2(1) = 0 p2b(1)= 1 p2(2) = 1 - p2b(2) f = f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ipo_mapping_inverse @ %def sf_ipo_mapping_inverse @ \subsection{Implementation: Endpoint + ISR power mapping} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping. The first two parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. <>= public :: sf_ei_mapping_t <>= type, extends (sf_mapping_t) :: sf_ei_mapping_t type(sf_ep_mapping_t) :: ep type(sf_ip_mapping_t) :: ip contains <> end type sf_ei_mapping_t @ %def sf_ei_mapping_t @ Output. <>= procedure :: write => sf_ei_mapping_write <>= subroutine sf_ei_mapping_write (object, unit) class(sf_ei_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,ES12.5,A,ES12.5,A)") ": ep/isr (a =", object%ep%a, & ", eps =", object%ip%eps, ")" end subroutine sf_ei_mapping_write @ %def sf_ei_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ei_mapping_init <>= subroutine sf_ei_mapping_init (mapping, a, eps) class(sf_ei_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps call mapping%base_init (4) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_ei_mapping_init @ %def sf_ei_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_ei_mapping_set_index <>= subroutine sf_ei_mapping_set_index (mapping, j, i) class(sf_ei_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_ei_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_ei_mapping_compute <>= subroutine sf_ei_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: q, qb real(default) :: f1, f2 call mapping%ep%compute (q, qb, f1, p, pb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f1 * f2 end subroutine sf_ei_mapping_compute @ %def sf_ei_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ei_mapping_inverse <>= subroutine sf_ei_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: q, qb real(default) :: f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, p, pb, x_free) f = f1 * f2 end subroutine sf_ei_mapping_inverse @ %def sf_ei_mapping_inverse @ \subsection{Implementation: Endpoint + ISR + resonance} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping, adapted for an s-channel resonance. The first two internal parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. The first and third parameters are the result of an overall resonance mapping, so on the outside, the first parameter is the total momentum fraction, the third one describes the distribution between beamstrahlung and ISR. <>= public :: sf_eir_mapping_t <>= type, extends (sf_mapping_t) :: sf_eir_mapping_t type(sf_res_mapping_t) :: res type(sf_epr_mapping_t) :: ep type(sf_ipr_mapping_t) :: ip contains <> end type sf_eir_mapping_t @ %def sf_eir_mapping_t @ Output. <>= procedure :: write => sf_eir_mapping_write <>= subroutine sf_eir_mapping_write (object, unit) class(sf_eir_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A,F7.5,', ',F7.5,A)") & ": ep/isr/res (a =", object%ep%a, & ", eps =", object%ip%eps, " | ", object%res%m, object%res%w, ")" end subroutine sf_eir_mapping_write @ %def sf_eir_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_eir_mapping_init <>= subroutine sf_eir_mapping_init (mapping, a, eps, m, w) class(sf_eir_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, eps, m, w call mapping%base_init (4) call mapping%res%init (m, w) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_eir_mapping_init @ %def sf_eir_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_eir_mapping_set_index <>= subroutine sf_eir_mapping_set_index (mapping, j, i) class(sf_eir_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1); call mapping%res%set_index (1, i) case (3); call mapping%res%set_index (2, i) end select select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_eir_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_eir_mapping_compute <>= subroutine sf_eir_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%res%compute (px, pxb, f0, p, pb, x_free) call mapping%ep%compute (q, qb, f1, px, pxb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f0 * f1 * f2 end subroutine sf_eir_mapping_compute @ %def sf_eir_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_eir_mapping_inverse <>= subroutine sf_eir_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, px, pxb, x_free) call mapping%res%inverse (px, pxb, f0, p, pb, x_free) f = f0 * f1 * f2 end subroutine sf_eir_mapping_inverse @ %def sf_eir_mapping_inverse @ \subsection{Implementation: Endpoint + ISR power mapping, on-shell} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping. The first two parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. On top of that, we map the first and third parameter such that the product is constant. From the outside, the first parameter is irrelevant while the third parameter describes the distribution of energy (loss) among beamstrahlung and ISR. <>= public :: sf_eio_mapping_t <>= type, extends (sf_mapping_t) :: sf_eio_mapping_t type(sf_os_mapping_t) :: os type(sf_epr_mapping_t) :: ep type(sf_ipr_mapping_t) :: ip contains <> end type sf_eio_mapping_t @ %def sf_eio_mapping_t @ Output. <>= procedure :: write => sf_eio_mapping_write <>= subroutine sf_eio_mapping_write (object, unit) class(sf_eio_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A,F7.5,A)") ": ep/isr/os (a =", object%ep%a, & ", eps =", object%ip%eps, " | ", object%os%m, ")" end subroutine sf_eio_mapping_write @ %def sf_eio_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_eio_mapping_init <>= subroutine sf_eio_mapping_init (mapping, a, eps, m) class(sf_eio_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps, m call mapping%base_init (4) call mapping%os%init (m) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_eio_mapping_init @ %def sf_eio_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_eio_mapping_set_index <>= subroutine sf_eio_mapping_set_index (mapping, j, i) class(sf_eio_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1); call mapping%os%set_index (1, i) case (3); call mapping%os%set_index (2, i) end select select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_eio_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_eio_mapping_compute <>= subroutine sf_eio_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%os%compute (px, pxb, f0, p, pb, x_free) call mapping%ep%compute (q, qb, f1, px, pxb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f0 * f1 * f2 end subroutine sf_eio_mapping_compute @ %def sf_eio_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_eio_mapping_inverse <>= subroutine sf_eio_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, px, pxb, x_free) call mapping%os%inverse (px, pxb, f0, p, pb, x_free) f = f0 * f1 * f2 end subroutine sf_eio_mapping_inverse @ %def sf_eio_mapping_inverse @ \subsection{Basic formulas} \subsubsection{Standard mapping of the unit square} This mapping of the unit square is appropriate in particular for structure functions which are concentrated at the lower end. Instead of a rectangular grid, one set of grid lines corresponds to constant parton c.m. energy. The other set is chosen such that the jacobian is only mildly singular ($\ln x$ which is zero at $x=1$), corresponding to an initial concentration of sampling points at the maximum energy. If [[power]] is greater than one (the default), points are also concentrated at the lower end. The formula is ([[power]]=$\alpha$): \begin{align} r_1 &= (p_1 ^ {p_2})^\alpha \\ r_2 &= (p_1 ^ {1 - p_2})^\alpha\\ f &= \alpha^2 p_1 ^ {\alpha - 1} |\log p_1| \end{align} and for the default case $\alpha=1$: \begin{align} r_1 &= p_1 ^ {p_2} \\ r_2 &= p_1 ^ {1 - p_2} \\ f &= |\log p_1| \end{align} <>= subroutine map_unit_square (r, factor, p, power) real(default), dimension(2), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), intent(in), optional :: power real(default) :: xx, yy factor = 1 xx = p(1) yy = p(2) if (present(power)) then if (p(1) > 0 .and. power > 1) then xx = p(1)**power factor = factor * power * xx / p(1) end if end if if (.not. vanishes (xx)) then r(1) = xx ** yy r(2) = xx / r(1) factor = factor * abs (log (xx)) else r = 0 end if end subroutine map_unit_square @ %def map_unit_square @ This is the inverse mapping. <>= subroutine map_unit_square_inverse (r, factor, p, power) real(kind=default), dimension(2), intent(in) :: r real(kind=default), intent(out) :: factor real(kind=default), dimension(2), intent(out) :: p real(kind=default), intent(in), optional :: power real(kind=default) :: lg, xx, yy factor = 1 xx = r(1) * r(2) if (.not. vanishes (xx)) then lg = log (xx) if (.not. vanishes (lg)) then yy = log (r(1)) / lg else yy = 0 end if p(2) = yy factor = factor * abs (lg) if (present(power)) then p(1) = xx**(1._default/power) factor = factor * power * xx / p(1) else p(1) = xx end if else p = 0 end if end subroutine map_unit_square_inverse @ %def map_unit_square_inverse @ \subsubsection{Precise mapping of the unit square} A more precise version (with unit power parameter). This version should be numerically stable near $x=1$ and $y=0,1$. The formulas are again \begin{equation} r_1 = p_1^{p_2}, \qquad r_2 = p_1^{\bar p_2}, \qquad f = - \log p_1 \end{equation} but we compute both $r_i$ and $\bar r_i$ simultaneously and make direct use of both $p_i$ and $\bar p_i$ as appropriate. <>= subroutine map_unit_square_prec (r, rb, factor, p, pb) real(default), dimension(2), intent(out) :: r real(default), dimension(2), intent(out) :: rb real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), dimension(2), intent(in) :: pb if (p(1) > 0.5_default) then call compute_prec_xy_1 (r(1), rb(1), p(1), pb(1), p (2)) call compute_prec_xy_1 (r(2), rb(2), p(1), pb(1), pb(2)) factor = - log_prec (p(1), pb(1)) else if (.not. vanishes (p(1))) then call compute_prec_xy_0 (r(1), rb(1), p(1), pb(1), p (2)) call compute_prec_xy_0 (r(2), rb(2), p(1), pb(1), pb(2)) factor = - log_prec (p(1), pb(1)) else r = 0 rb = 1 factor = 0 end if end subroutine map_unit_square_prec @ %def map_unit_square_prec @ This is the inverse mapping. <>= subroutine map_unit_square_inverse_prec (r, rb, factor, p, pb) real(default), dimension(2), intent(in) :: r real(default), dimension(2), intent(in) :: rb real(default), intent(out) :: factor real(default), dimension(2), intent(out) :: p real(default), dimension(2), intent(out) :: pb call inverse_prec_x (r, rb, p(1), pb(1)) if (all (r > 0)) then if (rb(1) < rb(2)) then call inverse_prec_y (r, rb, p(2), pb(2)) else call inverse_prec_y ([r(2),r(1)], [rb(2),rb(1)], pb(2), p(2)) end if factor = - log_prec (p(1), pb(1)) else p(1) = 0 pb(1) = 1 p(2) = 0.5_default pb(2) = 0.5_default factor = 0 end if end subroutine map_unit_square_inverse_prec @ %def map_unit_square_prec_inverse @ This is an auxiliary function: evaluate the expression $\bar z = 1 - x^y$ in a numerically stable way. Instabilities occur for $y=0$ and $x=1$. The idea is to replace the bracket by the first terms of its Taylor expansion around $x=1$ (read $\bar x\equiv 1 -x$) \begin{equation} 1 - x^y = y\bar x\left(1 + \frac12(1-y)\bar x + \frac16(2-y)(1-y)\bar x^2\right) \end{equation} whenever this is the better approximation. Actually, the relative numerical error of the exact formula is about $\eta/(y\bar x)$ where $\eta$ is given by [[epsilon(KIND)]] in Fortran. The relative error of the approximation is better than the last included term divided by $(y\bar x)$. The first subroutine computes $z$ and $\bar z$ near $x=1$ where $\log x$ should be expanded, the second one near $x=0$ where $\log x$ can be kept. <>= subroutine compute_prec_xy_1 (z, zb, x, xb, y) real(default), intent(out) :: z, zb real(default), intent(in) :: x, xb, y real(default) :: a1, a2, a3 a1 = y * xb a2 = a1 * (1 - y) * xb / 2 a3 = a2 * (2 - y) * xb / 3 if (abs (a3) < epsilon (a3)) then zb = a1 + a2 + a3 z = 1 - zb else z = x ** y zb = 1 - z end if end subroutine compute_prec_xy_1 subroutine compute_prec_xy_0 (z, zb, x, xb, y) real(default), intent(out) :: z, zb real(default), intent(in) :: x, xb, y real(default) :: a1, a2, a3, lx lx = -log (x) a1 = y * lx a2 = a1 * y * lx / 2 a3 = a2 * y * lx / 3 if (abs (a3) < epsilon (a3)) then zb = a1 + a2 + a3 z = 1 - zb else z = x ** y zb = 1 - z end if end subroutine compute_prec_xy_0 @ %def compute_prec_xy_1 @ %def compute_prec_xy_0 @ For the inverse calculation, we evaluate $x=r_1r_2$ in a stable way. Since it is just a polynomial, the expansion near $x=1$ is analytically exact, and we don't need to choose based on precision. <>= subroutine inverse_prec_x (r, rb, x, xb) real(default), dimension(2), intent(in) :: r, rb real(default), intent(out) :: x, xb real(default) :: a0, a1 a0 = rb(1) + rb(2) a1 = rb(1) * rb(2) if (a0 > 0.5_default) then xb = a0 - a1 x = 1 - xb else x = r(1) * r(2) xb = 1 - x end if end subroutine inverse_prec_x @ %def inverse_prec_x @ The inverse calculation for the relative momentum fraction \begin{equation} y = \frac{1}{1 + \frac{\log{r_2}}{\log{r_1}}} \end{equation} is slightly more complicated. We should take the precise form of the logarithm, so we are safe near $r_i=1$. A series expansion is required if $r_1\ll r_2$, since then $y$ becomes small. (We assume $r_1>= subroutine inverse_prec_y (r, rb, y, yb) real(default), dimension(2), intent(in) :: r, rb real(default), intent(out) :: y, yb real(default) :: log1, log2, a1, a2, a3 log1 = log_prec (r(1), rb(1)) log2 = log_prec (r(2), rb(2)) if (abs (log2**3) < epsilon (one)) then if (abs(log1) < epsilon (one)) then y = zero else y = one / (one + log2 / log1) end if if (abs(log2) < epsilon (one)) then yb = zero else yb = one / (one + log1 / log2) end if return end if a1 = - rb(1) / log2 a2 = - rb(1) ** 2 * (one / log2**2 + one / (2 * log2)) a3 = - rb(1) ** 3 * (one / log2**3 + one / log2**2 + one/(3 * log2)) if (abs (a3) < epsilon (a3)) then y = a1 + a2 + a3 yb = one - y else y = one / (one + log2 / log1) yb = one / (one + log1 / log2) end if end subroutine inverse_prec_y @ %def inverse_prec_y @ \subsubsection{Mapping for on-shell s-channel} The limiting case, if the product $r_1r_2$ is fixed for on-shell production. The parameter $p_1$ is ignored. In the inverse mapping, it is returned zero. The parameter [[x_free]], if present, rescales the total energy. If it is less than one, the rescaled mass parameter $m^2$ should be increased accordingly. Public for access in unit test. <>= public :: map_on_shell public :: map_on_shell_inverse <>= subroutine map_on_shell (r, factor, p, lm2, x_free) real(default), dimension(2), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) r(1) = exp (- p(2) * lx) r(2) = exp (- (1 - p(2)) * lx) factor = lx end subroutine map_on_shell subroutine map_on_shell_inverse (r, factor, p, lm2, x_free) real(default), dimension(2), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) p(1) = 0 p(2) = abs (log (r(1))) / lx factor = lx end subroutine map_on_shell_inverse @ %def map_on_shell @ %def map_on_shell_inverse @ \subsubsection{Mapping for on-shell s-channel, single parameter} This is a pseudo-mapping which applies if there is actually just one parameter [[p]]. The output parameter [[r]] is fixed for on-shell production. The lone parameter $p_1$ is ignored. In the inverse mapping, it is returned zero. The parameter [[x_free]], if present, rescales the total energy. If it is less than one, the rescaled mass parameter $m^2$ should be increased accordingly. Public for access in unit test. <>= public :: map_on_shell_single public :: map_on_shell_single_inverse <>= subroutine map_on_shell_single (r, factor, p, lm2, x_free) real(default), dimension(1), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) r(1) = exp (- lx) factor = 1 end subroutine map_on_shell_single subroutine map_on_shell_single_inverse (r, factor, p, lm2, x_free) real(default), dimension(1), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) p(1) = 0 factor = 1 end subroutine map_on_shell_single_inverse @ %def map_on_shell_single @ %def map_on_shell_single_inverse @ \subsubsection{Mapping for a Breit-Wigner resonance} This is the standard Breit-Wigner mapping. We apply it to a single variable, independently of or in addition to a unit-square mapping. We assume here that the limits for the variable are 0 and 1, and that the mass $m$ and width $w$ are rescaled appropriately, so they are dimensionless and usually between 0 and 1. If [[x_free]] is set, it rescales the total energy and thus mass and width, since these are defined with respect to the total energy. <>= subroutine map_breit_wigner (r, factor, p, m, w, x_free) real(default), intent(out) :: r real(default), intent(out) :: factor real(default), intent(in) :: p real(default), intent(in) :: m real(default), intent(in) :: w real(default), intent(in), optional :: x_free real(default) :: m2, mw, a1, a2, a3, z, tmp m2 = m ** 2 mw = m * w if (present (x_free)) then m2 = m2 / x_free mw = mw / x_free end if a1 = atan (- m2 / mw) a2 = atan ((1 - m2) / mw) a3 = (a2 - a1) * mw z = (1-p) * a1 + p * a2 if (-pi/2 < z .and. z < pi/2) then tmp = tan (z) r = max (m2 + mw * tmp, 0._default) factor = a3 * (1 + tmp ** 2) else r = 0 factor = 0 end if end subroutine map_breit_wigner subroutine map_breit_wigner_inverse (r, factor, p, m, w, x_free) real(default), intent(in) :: r real(default), intent(out) :: factor real(default), intent(out) :: p real(default), intent(in) :: m real(default), intent(in) :: w real(default) :: m2, mw, a1, a2, a3, tmp real(default), intent(in), optional :: x_free m2 = m ** 2 mw = m * w if (present (x_free)) then m2 = m2 / x_free mw = mw / x_free end if a1 = atan (- m2 / mw) a2 = atan ((1 - m2) / mw) a3 = (a2 - a1) * mw tmp = (r - m2) / mw p = (atan (tmp) - a1) / (a2 - a1) factor = a3 * (1 + tmp ** 2) end subroutine map_breit_wigner_inverse @ %def map_breit_wigner @ %def map_breit_wigner_inverse @ \subsubsection{Mapping with endpoint enhancement} This is a mapping which is close to the unit mapping, except that at the endpoint(s), the output values are exponentially enhanced. \begin{equation} y = \tanh (a \tan (\frac{\pi}{2}x)) \end{equation} We have two variants: one covers endpoints at $0$ and $1$ symmetrically, while the other one (which essentially maps one-half of the range), covers only the endpoint at $1$. <>= subroutine map_endpoint_1 (x3, factor, x1, a) real(default), intent(out) :: x3, factor real(default), intent(in) :: x1 real(default), intent(in) :: a real(default) :: x2 if (abs (x1) < 1) then x2 = tan (x1 * pi / 2) x3 = tanh (a * x2) factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2) else x3 = x1 factor = 0 end if end subroutine map_endpoint_1 subroutine map_endpoint_inverse_1 (x3, factor, x1, a) real(default), intent(in) :: x3 real(default), intent(out) :: x1, factor real(default), intent(in) :: a real(default) :: x2 if (abs (x3) < 1) then x2 = atanh (x3) / a x1 = 2 / pi * atan (x2) factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2) else x1 = x3 factor = 0 end if end subroutine map_endpoint_inverse_1 subroutine map_endpoint_01 (x4, factor, x0, a) real(default), intent(out) :: x4, factor real(default), intent(in) :: x0 real(default), intent(in) :: a real(default) :: x1, x3 x1 = 2 * x0 - 1 call map_endpoint_1 (x3, factor, x1, a) x4 = (x3 + 1) / 2 end subroutine map_endpoint_01 subroutine map_endpoint_inverse_01 (x4, factor, x0, a) real(default), intent(in) :: x4 real(default), intent(out) :: x0, factor real(default), intent(in) :: a real(default) :: x1, x3 x3 = 2 * x4 - 1 call map_endpoint_inverse_1 (x3, factor, x1, a) x0 = (x1 + 1) / 2 end subroutine map_endpoint_inverse_01 @ %def map_endpoint_1 @ %def map_endpoint_inverse_1 @ %def map_endpoint_01 @ %def map_endpoint_inverse_01 @ \subsubsection{Mapping with endpoint enhancement (ISR)} This is another endpoint mapping. It is designed to flatten the ISR singularity which is of power type at $x=1$, i.e., if \begin{equation} \sigma = \int_0^1 dx\,f(x)\,G(x) = \int_0^1 dx\,\epsilon(1-x)^{-1+\epsilon} G(x), \end{equation} we replace this by \begin{equation} r = x^\epsilon \quad\Longrightarrow\quad \sigma = \int_0^1 dr\,G(1- (1-r)^{1/\epsilon}). \end{equation} We expect that $\epsilon$ is small. The actual mapping is $r\to x$ (so $x$ emerges closer to $1$). The Jacobian that we return is thus $1/f(x)$. We compute the mapping in terms of $\bar x\equiv 1 - x$, so we can achieve the required precision. Because some compilers show quite wild numeric fluctuations, we internally convert numeric types to explicit [[double]] precision. <>= public :: map_power_1 public :: map_power_inverse_1 <>= subroutine map_power_1 (xb, factor, rb, eps) real(default), intent(out) :: xb, factor real(default), intent(in) :: rb real(double) :: rb_db, factor_db, eps_db, xb_db real(default), intent(in) :: eps rb_db = real (rb, kind=double) eps_db = real (eps, kind=double) xb_db = rb_db ** (1 / eps_db) if (rb_db > 0) then factor_db = xb_db / rb_db / eps_db factor = real (factor_db, kind=default) else factor = 0 end if xb = real (xb_db, kind=default) end subroutine map_power_1 subroutine map_power_inverse_1 (xb, factor, rb, eps) real(default), intent(in) :: xb real(default), intent(out) :: rb, factor real(double) :: xb_db, factor_db, eps_db, rb_db real(default), intent(in) :: eps xb_db = real (xb, kind=double) eps_db = real (eps, kind=double) rb_db = xb_db ** eps_db if (xb_db > 0) then factor_db = xb_db / rb_db / eps_db factor = real (factor_db, kind=default) else factor = 0 end if rb = real (rb_db, kind=default) end subroutine map_power_inverse_1 @ %def map_power_1 @ %def map_power_inverse_1 @ Here we apply a power mapping to both endpoints. We divide the interval in two equal halves and apply the power mapping for the nearest endpoint, either $0$ or $1$. <>= subroutine map_power_01 (y, yb, factor, r, eps) real(default), intent(out) :: y, yb, factor real(default), intent(in) :: r real(default), intent(in) :: eps real(default) :: u, ub, zp, zm u = 2 * r - 1 if (u > 0) then ub = 2 * (1 - r) call map_power_1 (zm, factor, ub, eps) zp = 2 - zm else if (u < 0) then ub = 2 * r call map_power_1 (zp, factor, ub, eps) zm = 2 - zp else factor = 1 / eps zp = 1 zm = 1 end if y = zp / 2 yb = zm / 2 end subroutine map_power_01 subroutine map_power_inverse_01 (y, yb, factor, r, eps) real(default), intent(in) :: y, yb real(default), intent(out) :: r, factor real(default), intent(in) :: eps real(default) :: ub, zp, zm zp = 2 * y zm = 2 * yb if (zm < zp) then call map_power_inverse_1 (zm, factor, ub, eps) r = 1 - ub / 2 else if (zp < zm) then call map_power_inverse_1 (zp, factor, ub, eps) r = ub / 2 else factor = 1 / eps ub = 1 r = ub / 2 end if end subroutine map_power_inverse_01 @ %def map_power_01 @ %def map_power_inverse_01 @ \subsubsection{Structure-function channels} A structure-function chain parameterization (channel) may contain a mapping that applies to multiple structure functions. This is described by an extension of the [[sf_mapping_t]] type. In addition, it may contain mappings that apply to (other) individual structure functions. The details of these mappings are implementation-specific. The [[sf_channel_t]] type combines this information. It contains an array of map codes, one for each structure-function entry. The code values are: \begin{description} \item[none] MC input parameters $r$ directly become energy fractions $x$ \item[single] default mapping for a single structure-function entry \item[multi/s] map $r\to x$ such that one MC input parameter is $\hat s/s$ \item[multi/resonance] as before, adapted to s-channel resonance \item[multi/on-shell] as before, adapted to an on-shell particle in the s channel \item[multi/endpoint] like multi/s, but enhance the region near $r_i=1$ \item[multi/endpoint/res] endpoint mapping with resonance \item[multi/endpoint/os] endpoint mapping for on-shell \item[multi/power/os] like multi/endpoint, regulating a power singularity \end{description} <>= integer, parameter :: SFMAP_NONE = 0 integer, parameter :: SFMAP_SINGLE = 1 integer, parameter :: SFMAP_MULTI_S = 2 integer, parameter :: SFMAP_MULTI_RES = 3 integer, parameter :: SFMAP_MULTI_ONS = 4 integer, parameter :: SFMAP_MULTI_EP = 5 integer, parameter :: SFMAP_MULTI_EPR = 6 integer, parameter :: SFMAP_MULTI_EPO = 7 integer, parameter :: SFMAP_MULTI_IP = 8 integer, parameter :: SFMAP_MULTI_IPR = 9 integer, parameter :: SFMAP_MULTI_IPO = 10 integer, parameter :: SFMAP_MULTI_EI = 11 integer, parameter :: SFMAP_MULTI_SRS = 13 integer, parameter :: SFMAP_MULTI_SON = 14 @ %def SFMAP_NONE SFMAP_SINGLE @ %def SFMAP_MULTI_S SFMAP_MULTI_RES SFMAP_MULTI_ONS @ %def SFMAP_MULTI_EP SFMAP_MULTI_EPR SFMAP_MULTI_EPO @ %def SFMAP_MULTI_IP SFMAP_MULTI_IPR SFMAP_MULTI_IPO @ %def SFMAP_MULTI_EI @ %def SFMAP_MULTI_SRS SFMAP_MULTI_SON @ Then, it contains an allocatable entry for the multi mapping. This entry holds the MC-parameter indices on which the mapping applies (there may be more than one MC parameter per structure-function entry) and any parameters associated with the mapping. There can be only one multi-mapping per channel. <>= public :: sf_channel_t <>= type :: sf_channel_t integer, dimension(:), allocatable :: map_code class(sf_mapping_t), allocatable :: multi_mapping contains <> end type sf_channel_t @ %def sf_channel_t @ The output format prints a single character for each structure-function entry and, if applicable, an account of the mapping parameters. <>= procedure :: write => sf_channel_write <>= subroutine sf_channel_write (object, unit) class(sf_channel_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) if (allocated (object%map_code)) then do i = 1, size (object%map_code) select case (object%map_code (i)) case (SFMAP_NONE) write (u, "(1x,A)", advance="no") "-" case (SFMAP_SINGLE) write (u, "(1x,A)", advance="no") "+" case (SFMAP_MULTI_S) write (u, "(1x,A)", advance="no") "s" case (SFMAP_MULTI_RES, SFMAP_MULTI_SRS) write (u, "(1x,A)", advance="no") "r" case (SFMAP_MULTI_ONS, SFMAP_MULTI_SON) write (u, "(1x,A)", advance="no") "o" case (SFMAP_MULTI_EP) write (u, "(1x,A)", advance="no") "e" case (SFMAP_MULTI_EPR) write (u, "(1x,A)", advance="no") "p" case (SFMAP_MULTI_EPO) write (u, "(1x,A)", advance="no") "q" case (SFMAP_MULTI_IP) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_IPR) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_IPO) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_EI) write (u, "(1x,A)", advance="no") "i" case default write (u, "(1x,A)", advance="no") "?" end select end do else write (u, "(1x,A)", advance="no") "-" end if if (allocated (object%multi_mapping)) then write (u, "(1x,'/')", advance="no") call object%multi_mapping%write (u) else write (u, *) end if end subroutine sf_channel_write @ %def sf_channel_write @ Initializer for a single [[sf_channel]] object. <>= procedure :: init => sf_channel_init <>= subroutine sf_channel_init (channel, n_strfun) class(sf_channel_t), intent(out) :: channel integer, intent(in) :: n_strfun allocate (channel%map_code (n_strfun)) channel%map_code = SFMAP_NONE end subroutine sf_channel_init @ %def sf_channel_init @ Assignment. This merely copies intrinsic assignment. <>= generic :: assignment (=) => sf_channel_assign procedure :: sf_channel_assign <>= subroutine sf_channel_assign (copy, original) class(sf_channel_t), intent(out) :: copy type(sf_channel_t), intent(in) :: original allocate (copy%map_code (size (original%map_code))) copy%map_code = original%map_code if (allocated (original%multi_mapping)) then allocate (copy%multi_mapping, source = original%multi_mapping) end if end subroutine sf_channel_assign @ %def sf_channel_assign @ This initializer allocates an array of channels with common number of structure-function entries, therefore it is not a type-bound procedure. <>= public :: allocate_sf_channels <>= subroutine allocate_sf_channels (channel, n_channel, n_strfun) type(sf_channel_t), dimension(:), intent(out), allocatable :: channel integer, intent(in) :: n_channel integer, intent(in) :: n_strfun integer :: c allocate (channel (n_channel)) do c = 1, n_channel call channel(c)%init (n_strfun) end do end subroutine allocate_sf_channels @ %def allocate_sf_channels @ This marks a given subset of indices as single-mapping. <>= procedure :: activate_mapping => sf_channel_activate_mapping <>= subroutine sf_channel_activate_mapping (channel, i_sf) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf channel%map_code(i_sf) = SFMAP_SINGLE end subroutine sf_channel_activate_mapping @ %def sf_channel_activate_mapping @ This sets an s-channel multichannel mapping. The parameter indices are not yet set. <>= procedure :: set_s_mapping => sf_channel_set_s_mapping <>= subroutine sf_channel_set_s_mapping (channel, i_sf, power) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: power channel%map_code(i_sf) = SFMAP_MULTI_S allocate (sf_s_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_s_mapping_t) call mapping%init (power) end select end subroutine sf_channel_set_s_mapping @ %def sf_channel_set_s_mapping @ This sets an s-channel resonance multichannel mapping. <>= procedure :: set_res_mapping => sf_channel_set_res_mapping <>= subroutine sf_channel_set_res_mapping (channel, i_sf, m, w, single) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: m, w logical, intent(in) :: single if (single) then channel%map_code(i_sf) = SFMAP_MULTI_SRS allocate (sf_res_mapping_single_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_res_mapping_single_t) call mapping%init (m, w) end select else channel%map_code(i_sf) = SFMAP_MULTI_RES allocate (sf_res_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_res_mapping_t) call mapping%init (m, w) end select end if end subroutine sf_channel_set_res_mapping @ %def sf_channel_set_res_mapping @ This sets an s-channel on-shell multichannel mapping. The length of the [[i_sf]] array must be 2. (The first parameter actually becomes an irrelevant dummy.) <>= procedure :: set_os_mapping => sf_channel_set_os_mapping <>= subroutine sf_channel_set_os_mapping (channel, i_sf, m, single) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: m logical, intent(in) :: single if (single) then channel%map_code(i_sf) = SFMAP_MULTI_SON allocate (sf_os_mapping_single_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_os_mapping_single_t) call mapping%init (m) end select else channel%map_code(i_sf) = SFMAP_MULTI_ONS allocate (sf_os_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_os_mapping_t) call mapping%init (m) end select end if end subroutine sf_channel_set_os_mapping @ %def sf_channel_set_os_mapping @ This sets an s-channel endpoint mapping. The parameter $a$ is the slope parameter (default 1); increasing it moves the endpoint region (at $x=1$ to lower values in the input parameter. region even more. <>= procedure :: set_ep_mapping => sf_channel_set_ep_mapping <>= subroutine sf_channel_set_ep_mapping (channel, i_sf, a) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a channel%map_code(i_sf) = SFMAP_MULTI_EP allocate (sf_ep_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ep_mapping_t) call mapping%init (a = a) end select end subroutine sf_channel_set_ep_mapping @ %def sf_channel_set_ep_mapping @ This sets a resonant endpoint mapping. <>= procedure :: set_epr_mapping => sf_channel_set_epr_mapping <>= subroutine sf_channel_set_epr_mapping (channel, i_sf, a, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: a, m, w channel%map_code(i_sf) = SFMAP_MULTI_EPR allocate (sf_epr_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_epr_mapping_t) call mapping%init (a, m, w) end select end subroutine sf_channel_set_epr_mapping @ %def sf_channel_set_epr_mapping @ This sets an on-shell endpoint mapping. <>= procedure :: set_epo_mapping => sf_channel_set_epo_mapping <>= subroutine sf_channel_set_epo_mapping (channel, i_sf, a, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: a, m channel%map_code(i_sf) = SFMAP_MULTI_EPO allocate (sf_epo_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_epo_mapping_t) call mapping%init (a, m) end select end subroutine sf_channel_set_epo_mapping @ %def sf_channel_set_epo_mapping @ This sets an s-channel power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ip_mapping => sf_channel_set_ip_mapping <>= subroutine sf_channel_set_ip_mapping (channel, i_sf, eps) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps channel%map_code(i_sf) = SFMAP_MULTI_IP allocate (sf_ip_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ip_mapping_t) call mapping%init (eps) end select end subroutine sf_channel_set_ip_mapping @ %def sf_channel_set_ip_mapping @ This sets an s-channel resonant power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$ in the presence of an s-channel resonance. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ipr_mapping => sf_channel_set_ipr_mapping <>= subroutine sf_channel_set_ipr_mapping (channel, i_sf, eps, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps, m, w channel%map_code(i_sf) = SFMAP_MULTI_IPR allocate (sf_ipr_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ipr_mapping_t) call mapping%init (eps, m, w) end select end subroutine sf_channel_set_ipr_mapping @ %def sf_channel_set_ipr_mapping @ This sets an on-shell power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$ for the production of a single on-shell particle.. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ipo_mapping => sf_channel_set_ipo_mapping <>= subroutine sf_channel_set_ipo_mapping (channel, i_sf, eps, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps, m channel%map_code(i_sf) = SFMAP_MULTI_IPO allocate (sf_ipo_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ipo_mapping_t) call mapping%init (eps, m) end select end subroutine sf_channel_set_ipo_mapping @ %def sf_channel_set_ipo_mapping @ This sets a combined endpoint/ISR mapping. <>= procedure :: set_ei_mapping => sf_channel_set_ei_mapping <>= subroutine sf_channel_set_ei_mapping (channel, i_sf, a, eps) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_ei_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ei_mapping_t) call mapping%init (a, eps) end select end subroutine sf_channel_set_ei_mapping @ %def sf_channel_set_ei_mapping @ This sets a combined endpoint/ISR mapping with resonance. <>= procedure :: set_eir_mapping => sf_channel_set_eir_mapping <>= subroutine sf_channel_set_eir_mapping (channel, i_sf, a, eps, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps, m, w channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_eir_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_eir_mapping_t) call mapping%init (a, eps, m, w) end select end subroutine sf_channel_set_eir_mapping @ %def sf_channel_set_eir_mapping @ This sets a combined endpoint/ISR mapping, on-shell. <>= procedure :: set_eio_mapping => sf_channel_set_eio_mapping <>= subroutine sf_channel_set_eio_mapping (channel, i_sf, a, eps, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps, m channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_eio_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_eio_mapping_t) call mapping%init (a, eps, m) end select end subroutine sf_channel_set_eio_mapping @ %def sf_channel_set_eio_mapping @ Return true if the mapping code at position [[i_sf]] is [[SFMAP_SINGLE]]. <>= procedure :: is_single_mapping => sf_channel_is_single_mapping <>= function sf_channel_is_single_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag flag = channel%map_code(i_sf) == SFMAP_SINGLE end function sf_channel_is_single_mapping @ %def sf_channel_is_single_mapping @ Return true if the mapping code at position [[i_sf]] is any of the [[SFMAP_MULTI]] mappings. <>= procedure :: is_multi_mapping => sf_channel_is_multi_mapping <>= function sf_channel_is_multi_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag select case (channel%map_code(i_sf)) case (SFMAP_NONE, SFMAP_SINGLE) flag = .false. case default flag = .true. end select end function sf_channel_is_multi_mapping @ %def sf_channel_is_multi_mapping @ Return the number of parameters that the multi-mapping requires. The mapping object must be allocated. <>= procedure :: get_multi_mapping_n_par => sf_channel_get_multi_mapping_n_par <>= function sf_channel_get_multi_mapping_n_par (channel) result (n_par) class(sf_channel_t), intent(in) :: channel integer :: n_par if (allocated (channel%multi_mapping)) then n_par = channel%multi_mapping%get_n_dim () else n_par = 0 end if end function sf_channel_get_multi_mapping_n_par @ %def sf_channel_is_multi_mapping @ Return true if there is any nontrivial mapping in any of the channels. <>= public :: any_sf_channel_has_mapping <>= function any_sf_channel_has_mapping (channel) result (flag) type(sf_channel_t), dimension(:), intent(in) :: channel logical :: flag integer :: c flag = .false. do c = 1, size (channel) flag = flag .or. any (channel(c)%map_code /= SFMAP_NONE) end do end function any_sf_channel_has_mapping @ %def any_sf_channel_has_mapping @ Set a parameter index for an active multi mapping. We assume that the index array is allocated properly. <>= procedure :: set_par_index => sf_channel_set_par_index <>= subroutine sf_channel_set_par_index (channel, j, i_par) class(sf_channel_t), intent(inout) :: channel integer, intent(in) :: j integer, intent(in) :: i_par associate (mapping => channel%multi_mapping) if (j >= 1 .and. j <= mapping%get_n_dim ()) then if (mapping%get_index (j) == 0) then call channel%multi_mapping%set_index (j, i_par) else call msg_bug ("Structure-function setup: mapping index set twice") end if else call msg_bug ("Structure-function setup: mapping index out of range") end if end associate end subroutine sf_channel_set_par_index @ %def sf_channel_set_par_index @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_mappings_ut.f90]]>>= <> module sf_mappings_ut use unit_tests use sf_mappings_uti <> <> contains <> end module sf_mappings_ut @ %def sf_mappings_ut @ <<[[sf_mappings_uti.f90]]>>= <> module sf_mappings_uti <> use format_defs, only: FMT_11, FMT_12, FMT_13, FMT_14, FMT_15, FMT_16 use sf_mappings <> <> contains <> end module sf_mappings_uti @ %def sf_mappings_ut @ API: driver for the unit tests below. <>= public :: sf_mappings_test <>= subroutine sf_mappings_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_mappings_test @ %def sf_mappings_test @ \subsubsection{Check standard mapping} Probe the standard mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_1, "sf_mappings_1", & "standard pair mapping", & u, results) <>= public :: sf_mappings_1 <>= subroutine sf_mappings_1 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_1" write (u, "(A)") "* Purpose: probe standard mapping" write (u, "(A)") allocate (sf_s_mapping_t :: mapping) select type (mapping) type is (sf_s_mapping_t) call mapping%init () call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) allocate (sf_s_mapping_t :: mapping) select type (mapping) type is (sf_s_mapping_t) call mapping%init (power=2._default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select write (u, *) call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_1" end subroutine sf_mappings_1 @ %def sf_mappings_1 @ \subsubsection{Channel entries} Construct channel entries and print them. <>= call test (sf_mappings_2, "sf_mappings_2", & "structure-function mapping channels", & u, results) <>= public :: sf_mappings_2 <>= subroutine sf_mappings_2 (u) integer, intent(in) :: u type(sf_channel_t), dimension(:), allocatable :: channel integer :: c write (u, "(A)") "* Test output: sf_mappings_2" write (u, "(A)") "* Purpose: construct and display & &mapping-channel objects" write (u, "(A)") call allocate_sf_channels (channel, n_channel = 8, n_strfun = 2) call channel(2)%activate_mapping ([1]) call channel(3)%set_s_mapping ([1,2]) call channel(4)%set_s_mapping ([1,2], power=2._default) call channel(5)%set_res_mapping ([1,2], m = 0.5_default, w = 0.1_default, single = .false.) call channel(6)%set_os_mapping ([1,2], m = 0.5_default, single = .false.) call channel(7)%set_res_mapping ([1], m = 0.5_default, w = 0.1_default, single = .true.) call channel(8)%set_os_mapping ([1], m = 0.5_default, single = .true.) call channel(3)%set_par_index (1, 1) call channel(3)%set_par_index (2, 4) call channel(4)%set_par_index (1, 1) call channel(4)%set_par_index (2, 4) call channel(5)%set_par_index (1, 1) call channel(5)%set_par_index (2, 3) call channel(6)%set_par_index (1, 1) call channel(6)%set_par_index (2, 2) call channel(7)%set_par_index (1, 1) call channel(8)%set_par_index (1, 1) do c = 1, size (channel) write (u, "(I0,':')", advance="no") c call channel(c)%write (u) end do write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_2" end subroutine sf_mappings_2 @ %def sf_mappings_2 @ \subsubsection{Check resonance mapping} Probe the resonance mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. The resonance mass is at $1/2$ the energy, the width is $1/10$. <>= call test (sf_mappings_3, "sf_mappings_3", & "resonant pair mapping", & u, results) <>= public :: sf_mappings_3 <>= subroutine sf_mappings_3 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_3" write (u, "(A)") "* Purpose: probe resonance pair mapping" write (u, "(A)") allocate (sf_res_mapping_t :: mapping) select type (mapping) type is (sf_res_mapping_t) call mapping%init (0.5_default, 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_3" end subroutine sf_mappings_3 @ %def sf_mappings_3 @ \subsubsection{Check on-shell mapping} Probe the on-shell mapping of the unit square for different parameter values. Also calculates integrals. In this case, the Jacobian is constant and given by $|\log m^2|$, so this is also the value of the integral. The factor results from the variable change in the $\delta$ function $\delta (m^2 - x_1x_2)$ which multiplies the cross section for the case at hand. For the test, the (rescaled) resonance mass is set at $1/2$ the energy. <>= call test (sf_mappings_4, "sf_mappings_4", & "on-shell pair mapping", & u, results) <>= public :: sf_mappings_4 <>= subroutine sf_mappings_4 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_4" write (u, "(A)") "* Purpose: probe on-shell pair mapping" write (u, "(A)") allocate (sf_os_mapping_t :: mapping) select type (mapping) type is (sf_os_mapping_t) call mapping%init (0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0,0.1):" p = [0._default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0,1.0):" p = [0._default, 1.0_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_4" end subroutine sf_mappings_4 @ %def sf_mappings_4 @ \subsubsection{Check endpoint mapping} Probe the endpoint mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_5, "sf_mappings_5", & "endpoint pair mapping", & u, results) <>= public :: sf_mappings_5 <>= subroutine sf_mappings_5 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_5" write (u, "(A)") "* Purpose: probe endpoint pair mapping" write (u, "(A)") allocate (sf_ep_mapping_t :: mapping) select type (mapping) type is (sf_ep_mapping_t) call mapping%init () call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_5" end subroutine sf_mappings_5 @ %def sf_mappings_5 @ \subsubsection{Check endpoint resonant mapping} Probe the endpoint mapping with resonance. Also calculates integrals. <>= call test (sf_mappings_6, "sf_mappings_6", & "endpoint resonant mapping", & u, results) <>= public :: sf_mappings_6 <>= subroutine sf_mappings_6 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_6" write (u, "(A)") "* Purpose: probe endpoint resonant mapping" write (u, "(A)") allocate (sf_epr_mapping_t :: mapping) select type (mapping) type is (sf_epr_mapping_t) call mapping%init (a = 1._default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Same mapping without resonance:" write (u, "(A)") allocate (sf_epr_mapping_t :: mapping) select type (mapping) type is (sf_epr_mapping_t) call mapping%init (a = 1._default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_6" end subroutine sf_mappings_6 @ %def sf_mappings_6 @ \subsubsection{Check endpoint on-shell mapping} Probe the endpoint mapping with an on-shell particle. Also calculates integrals. <>= call test (sf_mappings_7, "sf_mappings_7", & "endpoint on-shell mapping", & u, results) <>= public :: sf_mappings_7 <>= subroutine sf_mappings_7 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_7" write (u, "(A)") "* Purpose: probe endpoint on-shell mapping" write (u, "(A)") allocate (sf_epo_mapping_t :: mapping) select type (mapping) type is (sf_epo_mapping_t) call mapping%init (a = 1._default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_7" end subroutine sf_mappings_7 @ %def sf_mappings_7 @ \subsubsection{Check power mapping} Probe the power mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_8, "sf_mappings_8", & "power pair mapping", & u, results) <>= public :: sf_mappings_8 <>= subroutine sf_mappings_8 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_8" write (u, "(A)") "* Purpose: probe power pair mapping" write (u, "(A)") allocate (sf_ip_mapping_t :: mapping) select type (mapping) type is (sf_ip_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.99,0.02):" p = [0.99_default, 0.02_default] pb= [0.01_default, 0.98_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Probe at (0.99,0.98):" p = [0.99_default, 0.98_default] pb= [0.01_default, 0.02_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_8" end subroutine sf_mappings_8 @ %def sf_mappings_8 @ \subsubsection{Check resonant power mapping} Probe the power mapping of the unit square, adapted for an s-channel resonance, for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_9, "sf_mappings_9", & "power resonance mapping", & u, results) <>= public :: sf_mappings_9 <>= subroutine sf_mappings_9 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_9" write (u, "(A)") "* Purpose: probe power resonant pair mapping" write (u, "(A)") allocate (sf_ipr_mapping_t :: mapping) select type (mapping) type is (sf_ipr_mapping_t) call mapping%init (eps = 0.1_default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9999,0.02):" p = [0.9999_default, 0.02_default] pb= [0.0001_default, 0.98_default] call mapping%check (u, p, pb, FMT_11, FMT_12) write (u, *) write (u, "(A)") "Probe at (0.9999,0.98):" p = [0.9999_default, 0.98_default] pb= [0.0001_default, 0.02_default] call mapping%check (u, p, pb, FMT_11, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Same mapping without resonance:" write (u, "(A)") allocate (sf_ipr_mapping_t :: mapping) select type (mapping) type is (sf_ipr_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_9" end subroutine sf_mappings_9 @ %def sf_mappings_9 @ \subsubsection{Check on-shell power mapping} Probe the power mapping of the unit square, adapted for single-particle production, for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_10, "sf_mappings_10", & "power on-shell mapping", & u, results) <>= public :: sf_mappings_10 <>= subroutine sf_mappings_10 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_10" write (u, "(A)") "* Purpose: probe power on-shell mapping" write (u, "(A)") allocate (sf_ipo_mapping_t :: mapping) select type (mapping) type is (sf_ipo_mapping_t) call mapping%init (eps = 0.1_default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0,0.02):" p = [0._default, 0.02_default] pb= [1._default, 0.98_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Probe at (0,0.98):" p = [0._default, 0.98_default] pb= [1._default, 0.02_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_10" end subroutine sf_mappings_10 @ %def sf_mappings_10 @ \subsubsection{Check combined endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_11, "sf_mappings_11", & "endpoint/power combined mapping", & u, results) <>= public :: sf_mappings_11 <>= subroutine sf_mappings_11 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_11" write (u, "(A)") "* Purpose: probe power pair mapping" write (u, "(A)") allocate (sf_ei_mapping_t :: mapping) select type (mapping) type is (sf_ei_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_13, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_11" end subroutine sf_mappings_11 @ %def sf_mappings_11 @ \subsubsection{Check resonant endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_12, "sf_mappings_12", & "endpoint/power resonant combined mapping", & u, results) <>= public :: sf_mappings_12 <>= subroutine sf_mappings_12 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_12" write (u, "(A)") "* Purpose: probe resonant combined mapping" write (u, "(A)") allocate (sf_eir_mapping_t :: mapping) select type (mapping) type is (sf_eir_mapping_t) call mapping%init (a = 1._default, & eps = 0.1_default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_12" end subroutine sf_mappings_12 @ %def sf_mappings_12 @ \subsubsection{Check on-shell endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_13, "sf_mappings_13", & "endpoint/power on-shell combined mapping", & u, results) <>= public :: sf_mappings_13 <>= subroutine sf_mappings_13 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_13" write (u, "(A)") "* Purpose: probe on-shell combined mapping" write (u, "(A)") allocate (sf_eio_mapping_t :: mapping) select type (mapping) type is (sf_eio_mapping_t) call mapping%init (a = 1._default, eps = 0.1_default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_13" end subroutine sf_mappings_13 @ %def sf_mappings_13 @ \subsubsection{Check rescaling} Check the rescaling factor in on-shell basic mapping. <>= call test (sf_mappings_14, "sf_mappings_14", & "rescaled on-shell mapping", & u, results) <>= public :: sf_mappings_14 <>= subroutine sf_mappings_14 (u) integer, intent(in) :: u real(default), dimension(2) :: p2, r2 real(default), dimension(1) :: p1, r1 real(default) :: f, x_free, m2 write (u, "(A)") "* Test output: sf_mappings_14" write (u, "(A)") "* Purpose: probe rescaling in os mapping" write (u, "(A)") x_free = 0.9_default m2 = 0.5_default write (u, "(A)") "* Two parameters" write (u, "(A)") p2 = [0.1_default, 0.2_default] call map_on_shell (r2, f, p2, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r2) write (u, *) call map_on_shell_inverse (r2, f, p2, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r2) write (u, "(A)") write (u, "(A)") "* One parameter" write (u, "(A)") p1 = [0.1_default] call map_on_shell_single (r1, f, p1, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r1) write (u, *) call map_on_shell_single_inverse (r1, f, p1, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r1) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_14" end subroutine sf_mappings_14 @ %def sf_mappings_14 @ \subsubsection{Check single parameter resonance mapping} Probe the resonance mapping of the unit interval for different parameter values. Also calculates integrals. The resonance mass is at $1/2$ the energy, the width is $1/10$. <>= call test (sf_mappings_15, "sf_mappings_15", & "resonant single mapping", & u, results) <>= public :: sf_mappings_15 <>= subroutine sf_mappings_15 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(1) :: p write (u, "(A)") "* Test output: sf_mappings_15" write (u, "(A)") "* Purpose: probe resonance single mapping" write (u, "(A)") allocate (sf_res_mapping_single_t :: mapping) select type (mapping) type is (sf_res_mapping_single_t) call mapping%init (0.5_default, 0.1_default) call mapping%set_index (1, 1) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0):" p = [0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5):" p = [0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1):" p = [0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_15" end subroutine sf_mappings_15 @ %def sf_mappings_15 @ \subsubsection{Check single parameter on-shell mapping} Probe the on-shell (pseudo) mapping of the unit interval for different parameter values. Also calculates integrals. The resonance mass is at $1/2$ the energy. <>= call test (sf_mappings_16, "sf_mappings_16", & "on-shell single mapping", & u, results) <>= public :: sf_mappings_16 <>= subroutine sf_mappings_16 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(1) :: p write (u, "(A)") "* Test output: sf_mappings_16" write (u, "(A)") "* Purpose: probe on-shell single mapping" write (u, "(A)") allocate (sf_os_mapping_single_t :: mapping) select type (mapping) type is (sf_os_mapping_single_t) call mapping%init (0.5_default) call mapping%set_index (1, 1) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0):" p = [0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5):" p = [0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_16" end subroutine sf_mappings_16 @ %def sf_mappings_16 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Structure function base} <<[[sf_base.f90]]>>= <> module sf_base <> <> use io_units use format_utils, only: write_separator use format_defs, only: FMT_17, FMT_19 + use numeric_utils, only: pacify use diagnostics use lorentz use quantum_numbers use interactions use evaluators use pdg_arrays use beams use sf_aux use sf_mappings use constants, only: one, two use physics_defs, only: n_beams_rescaled <> <> <> <> <> contains <> end module sf_base @ %def sf_base @ \subsection{Abstract rescale data-type} NLO calculations require the treatment of initial state parton radiation. The radiation of a parton rescales the energy fraction which enters the hard process. We allow for different rescale settings by extending the abstract. [[sf_rescale_t]] data type. <>= public :: sf_rescale_t <>= type, abstract :: sf_rescale_t integer :: i_beam = 0 contains <> end type sf_rescale_t @ %def sf_rescale_t @ <>= procedure (sf_rescale_apply), deferred :: apply <>= abstract interface subroutine sf_rescale_apply (func, x) import class(sf_rescale_t), intent(in) :: func real(default), intent(inout) :: x end subroutine sf_rescale_apply end interface @ %def rescale_apply @ <>= procedure :: set_i_beam => sf_rescale_set_i_beam <>= subroutine sf_rescale_set_i_beam (func, i_beam) class(sf_rescale_t), intent(inout) :: func integer, intent(in) :: i_beam func%i_beam = i_beam end subroutine sf_rescale_set_i_beam @ %def rescale_set_i_beam @ <>= public :: sf_rescale_collinear_t <>= type, extends (sf_rescale_t) :: sf_rescale_collinear_t real(default) :: xi_tilde contains <> end type sf_rescale_collinear_t @ %def sf_rescale_collinear_t @ For the subtraction terms we need to rescale the Born $x$ of both beams in the collinear limit. This leaves one beam unaffected and rescales the other according to \begin{equation} x = \frac{\overline{x}}{1-\xi} \end{equation} which is the collinear limit of [[sf_rescale_real_apply]]. <>= procedure :: apply => sf_rescale_collinear_apply <>= subroutine sf_rescale_collinear_apply (func, x) class(sf_rescale_collinear_t), intent(in) :: func real(default), intent(inout) :: x real(default) :: xi if (debug2_active (D_BEAMS)) then print *, 'Rescaling function - Collinear: ' print *, 'Input, unscaled x: ', x print *, 'xi_tilde: ', func%xi_tilde end if xi = func%xi_tilde * (one - x) x = x / (one - xi) if (debug2_active (D_BEAMS)) print *, 'rescaled x: ', x end subroutine sf_rescale_collinear_apply @ %def sf_rescale_collinear_apply @ <>= procedure :: set => sf_rescale_collinear_set <>= subroutine sf_rescale_collinear_set (func, xi_tilde) class(sf_rescale_collinear_t), intent(inout) :: func real(default), intent(in) :: xi_tilde func%xi_tilde = xi_tilde end subroutine sf_rescale_collinear_set @ %def sf_rescale_collinear_set @ <>= public :: sf_rescale_real_t <>= type, extends (sf_rescale_t) :: sf_rescale_real_t real(default) :: xi, y contains <> end type sf_rescale_real_t @ %def sf_rescale_real_t @ In case of IS Splittings, the beam $x$ changes from Born to real and thus needs to be rescaled according to \begin{equation} x_\oplus = \frac{\overline{x}_\oplus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1-y)}{2-\xi(1+y)}} , \qquad x_\ominus = \frac{\overline{x}_\ominus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1+y)}{2-\xi(1-y)}} \end{equation} Refs: \begin{itemize} \item[\textbullet] [0709.2092] Eq. (5.7). \item[\textbullet] [0907.4076] Eq. (2.21). \item Christian Weiss' PhD Thesis (DESY-THESIS-2017-025), Eq. (A.2.3). \end{itemize} <>= procedure :: apply => sf_rescale_real_apply <>= subroutine sf_rescale_real_apply (func, x) class(sf_rescale_real_t), intent(in) :: func real(default), intent(inout) :: x real(default) :: onepy, onemy if (debug2_active (D_BEAMS)) then print *, 'Rescaling function - Real: ' print *, 'Input, unscaled: ', x print *, 'Beam index: ', func%i_beam print *, 'xi: ', func%xi, 'y: ', func%y end if x = x / sqrt (one - func%xi) onepy = one + func%y; onemy = one - func%y if (func%i_beam == 1) then x = x * sqrt ((two - func%xi * onemy) / (two - func%xi * onepy)) else if (func%i_beam == 2) then x = x * sqrt ((two - func%xi * onepy) / (two - func%xi * onemy)) else call msg_fatal ("sf_rescale_real_apply - invalid beam index") end if if (debug2_active (D_BEAMS)) print *, 'rescaled x: ', x end subroutine sf_rescale_real_apply @ %def sf_rescale_real_apply @ <>= procedure :: set => sf_rescale_real_set <>= subroutine sf_rescale_real_set (func, xi, y) class(sf_rescale_real_t), intent(inout) :: func real(default), intent(in) :: xi, y func%xi = xi; func%y = y end subroutine sf_rescale_real_set @ %def sf_rescale_real_set <>= public :: sf_rescale_dglap_t <>= type, extends(sf_rescale_t) :: sf_rescale_dglap_t real(default), dimension(:), allocatable :: z contains <> end type sf_rescale_dglap_t @ %def sf_rescale_dglap_t @ <>= procedure :: apply => sf_rescale_dglap_apply <>= subroutine sf_rescale_dglap_apply (func, x) class(sf_rescale_dglap_t), intent(in) :: func real(default), intent(inout) :: x if (debug2_active (D_BEAMS)) then print *, "Rescaling function - DGLAP:" print *, "Input: ", x print *, "Beam index: ", func%i_beam print *, "z: ", func%z end if x = x / func%z(func%i_beam) if (debug2_active (D_BEAMS)) print *, "scaled x: ", x end subroutine sf_rescale_dglap_apply @ %def sf_rescale_dglap_apply @ <>= procedure :: set => sf_rescale_dglap_set <>= subroutine sf_rescale_dglap_set (func, z) class(sf_rescale_dglap_t), intent(inout) :: func real(default), dimension(:), intent(in) :: z ! allocate-on-assginment func%z = z end subroutine sf_rescale_dglap_set @ %def sf_rescale_dglap_set @ \subsection{Abstract structure-function data type} This type should hold all configuration data for a specific type of structure function. The base object is empty; the implementations will fill it. <>= public :: sf_data_t <>= type, abstract :: sf_data_t contains <> end type sf_data_t @ %def sf_data_t @ Output. <>= procedure (sf_data_write), deferred :: write <>= abstract interface subroutine sf_data_write (data, unit, verbose) import class(sf_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine sf_data_write end interface @ %def sf_data_write @ Return true if this structure function is in generator mode. In that case, all parameters are free, otherwise bound. (We do not support mixed cases.) Default is: no generator. <>= procedure :: is_generator => sf_data_is_generator <>= function sf_data_is_generator (data) result (flag) class(sf_data_t), intent(in) :: data logical :: flag flag = .false. end function sf_data_is_generator @ %def sf_data_is_generator @ Return the number of input parameters that determine the structure function. <>= procedure (sf_data_get_int), deferred :: get_n_par <>= abstract interface function sf_data_get_int (data) result (n) import class(sf_data_t), intent(in) :: data integer :: n end function sf_data_get_int end interface @ %def sf_data_get_int @ Return the outgoing particle PDG codes for the current setup. The codes can be an array of particles, for each beam. <>= procedure (sf_data_get_pdg_out), deferred :: get_pdg_out <>= abstract interface subroutine sf_data_get_pdg_out (data, pdg_out) import class(sf_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine sf_data_get_pdg_out end interface @ %def sf_data_get_pdg_out @ Allocate a matching structure function interaction object and properly initialize it. <>= procedure (sf_data_allocate_sf_int), deferred :: allocate_sf_int <>= abstract interface subroutine sf_data_allocate_sf_int (data, sf_int) import class(sf_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int end subroutine sf_data_allocate_sf_int end interface @ %def sf_data_allocate_sf_int @ Return the PDF set index, if applicable. We implement a default method which returns zero. The PDF (builtin and LHA) implementations will override this. <>= procedure :: get_pdf_set => sf_data_get_pdf_set <>= elemental function sf_data_get_pdf_set (data) result (pdf_set) class(sf_data_t), intent(in) :: data integer :: pdf_set pdf_set = 0 end function sf_data_get_pdf_set @ %def sf_data_get_pdf_set @ Return the spectrum file, if applicable. We implement a default method which returns zero. CIRCE1, CIRCE2 and the beam spectrum will override this. <>= procedure :: get_beam_file => sf_data_get_beam_file <>= function sf_data_get_beam_file (data) result (file) class(sf_data_t), intent(in) :: data type(string_t) :: file file = "" end function sf_data_get_beam_file @ %def sf_data_get_beam_file @ \subsection{Structure-function chain configuration} This is the data type that the [[process]] module uses for setting up its structure-function chain. For each structure function described by the beam data, there is an entry. The [[i]] array indicates the beam(s) to which this structure function applies, and the [[data]] object contains the actual configuration data. <>= public :: sf_config_t <>= type :: sf_config_t integer, dimension(:), allocatable :: i class(sf_data_t), allocatable :: data contains <> end type sf_config_t @ %def sf_config_t @ Output: <>= procedure :: write => sf_config_write <>= subroutine sf_config_write (object, unit, verbose) class(sf_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) if (allocated (object%i)) then write (u, "(1x,A,2(1x,I0))") "Structure-function configuration: & &beam(s)", object%i if (allocated (object%data)) & call object%data%write (u, verbose = verbose) else write (u, "(1x,A)") "Structure-function configuration: [undefined]" end if end subroutine sf_config_write @ %def sf_config_write @ Initialize. <>= procedure :: init => sf_config_init <>= subroutine sf_config_init (sf_config, i_beam, sf_data) class(sf_config_t), intent(out) :: sf_config integer, dimension(:), intent(in) :: i_beam class(sf_data_t), intent(in) :: sf_data allocate (sf_config%i (size (i_beam)), source = i_beam) allocate (sf_config%data, source = sf_data) end subroutine sf_config_init @ %def sf_config_init @ Return the PDF set, if any. <>= procedure :: get_pdf_set => sf_config_get_pdf_set <>= elemental function sf_config_get_pdf_set (sf_config) result (pdf_set) class(sf_config_t), intent(in) :: sf_config integer :: pdf_set pdf_set = sf_config%data%get_pdf_set () end function sf_config_get_pdf_set @ %def sf_config_get_pdf_set @ Return the beam spectrum file, if any. <>= procedure :: get_beam_file => sf_config_get_beam_file <>= function sf_config_get_beam_file (sf_config) result (file) class(sf_config_t), intent(in) :: sf_config type(string_t) :: file file = sf_config%data%get_beam_file () end function sf_config_get_beam_file @ %def sf_config_get_beam_file @ \subsection{Structure-function instance} The [[sf_int_t]] data type contains an [[interaction_t]] object (it is an extension of this type) and a pointer to the [[sf_data_t]] configuration data. This interaction, or copies of it, is used to implement structure-function kinematics and dynamics in the context of process evaluation. The status code [[status]] tells whether the interaction is undefined, has defined kinematics (but matrix elements invalid), or is completely defined. There is also a status code for failure. The implementation is responsible for updating the status. The entries [[mi2]], [[mr2]], and [[mo2]] hold the squared invariant masses of the incoming, radiated, and outgoing particle, respectively. They are supposed to be set upon initialization, but could also be varied event by event. If the radiated or outgoing mass is nonzero, we may need to apply an on-shell projection. The projection mode is stored as [[on_shell_mode]]. The array [[beam_index]] is the list of beams on which this structure function applies ($1$, $2$, or both). The arrays [[incoming]], [[radiated]], and [[outgoing]] contain the indices of the respective particle sets within the interaction, for convenient lookup. The array [[par_index]] indicates the MC input parameters that this entry will use up in the structure-function chain. The first parameter (or the first two, for a spectrum) in this array determines the momentum fraction and is thus subject to global mappings. In the abstract base type, we do not implement the data pointer. This allows us to restrict its type in the implementations. <>= public :: sf_int_t <>= type, abstract, extends (interaction_t) :: sf_int_t integer :: status = SF_UNDEFINED real(default), dimension(:), allocatable :: mi2 real(default), dimension(:), allocatable :: mr2 real(default), dimension(:), allocatable :: mo2 integer :: on_shell_mode = KEEP_ENERGY logical :: qmin_defined = .false. logical :: qmax_defined = .false. real(default), dimension(:), allocatable :: qmin real(default), dimension(:), allocatable :: qmax integer, dimension(:), allocatable :: beam_index integer, dimension(:), allocatable :: incoming integer, dimension(:), allocatable :: radiated integer, dimension(:), allocatable :: outgoing integer, dimension(:), allocatable :: par_index integer, dimension(:), allocatable :: par_primary contains <> end type sf_int_t @ %def sf_int_t @ Status codes. The codes that refer to links, masks, and connections, apply to structure-function chains only. The status codes are public. <>= integer, parameter, public :: SF_UNDEFINED = 0 integer, parameter, public :: SF_INITIAL = 1 integer, parameter, public :: SF_DONE_LINKS = 2 integer, parameter, public :: SF_FAILED_MASK = 3 integer, parameter, public :: SF_DONE_MASK = 4 integer, parameter, public :: SF_FAILED_CONNECTIONS = 5 integer, parameter, public :: SF_DONE_CONNECTIONS = 6 integer, parameter, public :: SF_SEED_KINEMATICS = 10 integer, parameter, public :: SF_FAILED_KINEMATICS = 11 integer, parameter, public :: SF_DONE_KINEMATICS = 12 integer, parameter, public :: SF_FAILED_EVALUATION = 13 integer, parameter, public :: SF_EVALUATED = 20 @ %def SF_UNDEFINED SF_INITIAL @ %def SF_DONE_LINKS SF_DONE_MASK SF_DONE_CONNECTIONS @ %def SF_DONE_KINEMATICS SF_EVALUATED @ %def SF_FAILED_MASK SF_FAILED_CONNECTIONS @ %def SF_FAILED_KINEMATICS SF_FAILED_EVALUATION @ Write a string version of the status code: <>= subroutine write_sf_status (status, u) integer, intent(in) :: status integer, intent(in) :: u select case (status) case (SF_UNDEFINED) write (u, "(1x,'[',A,']')") "undefined" case (SF_INITIAL) write (u, "(1x,'[',A,']')") "initialized" case (SF_DONE_LINKS) write (u, "(1x,'[',A,']')") "links set" case (SF_FAILED_MASK) write (u, "(1x,'[',A,']')") "mask mismatch" case (SF_DONE_MASK) write (u, "(1x,'[',A,']')") "mask set" case (SF_FAILED_CONNECTIONS) write (u, "(1x,'[',A,']')") "connections failed" case (SF_DONE_CONNECTIONS) write (u, "(1x,'[',A,']')") "connections set" case (SF_SEED_KINEMATICS) write (u, "(1x,'[',A,']')") "incoming momenta set" case (SF_FAILED_KINEMATICS) write (u, "(1x,'[',A,']')") "kinematics failed" case (SF_DONE_KINEMATICS) write (u, "(1x,'[',A,']')") "kinematics set" case (SF_FAILED_EVALUATION) write (u, "(1x,'[',A,']')") "evaluation failed" case (SF_EVALUATED) write (u, "(1x,'[',A,']')") "evaluated" end select end subroutine write_sf_status @ %def write_sf_status @ This is the basic output routine. Display status and interaction. <>= procedure :: base_write => sf_int_base_write <>= subroutine sf_int_base_write (object, unit, testflag) class(sf_int_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "SF instance:" call write_sf_status (object%status, u) if (allocated (object%beam_index)) & write (u, "(3x,A,2(1x,I0))") "beam =", object%beam_index if (allocated (object%incoming)) & write (u, "(3x,A,2(1x,I0))") "incoming =", object%incoming if (allocated (object%radiated)) & write (u, "(3x,A,2(1x,I0))") "radiated =", object%radiated if (allocated (object%outgoing)) & write (u, "(3x,A,2(1x,I0))") "outgoing =", object%outgoing if (allocated (object%par_index)) & write (u, "(3x,A,2(1x,I0))") "parameter =", object%par_index if (object%qmin_defined) & write (u, "(3x,A,1x," // FMT_19 // ")") "q_min =", object%qmin if (object%qmax_defined) & write (u, "(3x,A,1x," // FMT_19 // ")") "q_max =", object%qmax call object%interaction_t%basic_write (u, testflag = testflag) end subroutine sf_int_base_write @ %def sf_int_base_write @ The type string identifies the structure function class, and possibly more details about the structure function. <>= procedure (sf_int_type_string), deferred :: type_string <>= abstract interface function sf_int_type_string (object) result (string) import class(sf_int_t), intent(in) :: object type(string_t) :: string end function sf_int_type_string end interface @ %def sf_int_type_string @ Output of the concrete object. We should not forget to call the output routine for the base type. <>= procedure (sf_int_write), deferred :: write <>= abstract interface subroutine sf_int_write (object, unit, testflag) import class(sf_int_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine sf_int_write end interface @ %def sf_int_write @ Basic initialization: set the invariant masses for the particles and initialize the interaction. The caller should then add states to the interaction and freeze it. The dimension of the mask should be equal to the sum of the dimensions of the mass-squared arrays, which determine incoming, radiated, and outgoing particles, respectively. Optionally, we can define minimum and maximum values for the momentum transfer to the outgoing particle(s). If all masses are zero, this is actually required for non-collinear splitting. <>= procedure :: base_init => sf_int_base_init <>= subroutine sf_int_base_init & (sf_int, mask, mi2, mr2, mo2, qmin, qmax, hel_lock) class(sf_int_t), intent(out) :: sf_int type (quantum_numbers_mask_t), dimension(:), intent(in) :: mask real(default), dimension(:), intent(in) :: mi2, mr2, mo2 real(default), dimension(:), intent(in), optional :: qmin, qmax integer, dimension(:), intent(in), optional :: hel_lock allocate (sf_int%mi2 (size (mi2))) sf_int%mi2 = mi2 allocate (sf_int%mr2 (size (mr2))) sf_int%mr2 = mr2 allocate (sf_int%mo2 (size (mo2))) sf_int%mo2 = mo2 if (present (qmin)) then sf_int%qmin_defined = .true. allocate (sf_int%qmin (size (qmin))) sf_int%qmin = qmin end if if (present (qmax)) then sf_int%qmax_defined = .true. allocate (sf_int%qmax (size (qmax))) sf_int%qmax = qmax end if call sf_int%interaction_t%basic_init & (size (mi2), 0, size (mr2) + size (mo2), & mask = mask, hel_lock = hel_lock, set_relations = .true.) end subroutine sf_int_base_init @ %def sf_int_base_init @ Set the indices of the incoming, radiated, and outgoing particles, respectively. <>= procedure :: set_incoming => sf_int_set_incoming procedure :: set_radiated => sf_int_set_radiated procedure :: set_outgoing => sf_int_set_outgoing <>= subroutine sf_int_set_incoming (sf_int, incoming) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: incoming allocate (sf_int%incoming (size (incoming))) sf_int%incoming = incoming end subroutine sf_int_set_incoming subroutine sf_int_set_radiated (sf_int, radiated) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: radiated allocate (sf_int%radiated (size (radiated))) sf_int%radiated = radiated end subroutine sf_int_set_radiated subroutine sf_int_set_outgoing (sf_int, outgoing) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: outgoing allocate (sf_int%outgoing (size (outgoing))) sf_int%outgoing = outgoing end subroutine sf_int_set_outgoing @ %def sf_int_set_incoming @ %def sf_int_set_radiated @ %def sf_int_set_outgoing @ Initialization. This proceeds via an abstract data object, which for the actual implementation should have the matching concrete type. Since all implementations have the same signature, we can prepare a deferred procedure. The data object will become the target of a corresponding pointer within the [[sf_int_t]] implementation. This should call the previous procedure. <>= procedure (sf_int_init), deferred :: init <>= abstract interface subroutine sf_int_init (sf_int, data) import class(sf_int_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine sf_int_init end interface @ %def sf_int_init @ Complete initialization. This routine contains initializations that can only be performed after the interaction object got its final shape, i.e., redundant helicities have been eliminated by matching with beams and process. The default implementation does nothing. The [[target]] attribute is formally required since some overriding implementations use a temporary pointer (iterator) to the state-matrix component. It doesn't appear to make a real difference, though. <>= procedure :: setup_constants => sf_int_setup_constants <>= subroutine sf_int_setup_constants (sf_int) class(sf_int_t), intent(inout), target :: sf_int end subroutine sf_int_setup_constants @ %def sf_int_setup_constants @ Set beam indices, i.e., the beam(s) on which this structure function applies. <>= procedure :: set_beam_index => sf_int_set_beam_index <>= subroutine sf_int_set_beam_index (sf_int, beam_index) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: beam_index allocate (sf_int%beam_index (size (beam_index))) sf_int%beam_index = beam_index end subroutine sf_int_set_beam_index @ %def sf_int_set_beam_index @ Set parameter indices, indicating which MC input parameters are to be used for evaluating this structure function. <>= procedure :: set_par_index => sf_int_set_par_index <>= subroutine sf_int_set_par_index (sf_int, par_index) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: par_index allocate (sf_int%par_index (size (par_index))) sf_int%par_index = par_index end subroutine sf_int_set_par_index @ %def sf_int_set_par_index @ Initialize the structure-function kinematics, setting incoming momenta. We assume that array shapes match. Three versions. The first version relies on the momenta being linked to another interaction. The second version sets the momenta explicitly. In the third version, we first compute momenta for the specified energies and store those. <>= generic :: seed_kinematics => sf_int_receive_momenta generic :: seed_kinematics => sf_int_seed_momenta generic :: seed_kinematics => sf_int_seed_energies procedure :: sf_int_receive_momenta procedure :: sf_int_seed_momenta procedure :: sf_int_seed_energies <>= subroutine sf_int_receive_momenta (sf_int) class(sf_int_t), intent(inout) :: sf_int if (sf_int%status >= SF_INITIAL) then call sf_int%receive_momenta () sf_int%status = SF_SEED_KINEMATICS end if end subroutine sf_int_receive_momenta subroutine sf_int_seed_momenta (sf_int, k) class(sf_int_t), intent(inout) :: sf_int type(vector4_t), dimension(:), intent(in) :: k if (sf_int%status >= SF_INITIAL) then call sf_int%set_momenta (k, outgoing=.false.) sf_int%status = SF_SEED_KINEMATICS end if end subroutine sf_int_seed_momenta subroutine sf_int_seed_energies (sf_int, E) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: E type(vector4_t), dimension(:), allocatable :: k integer :: j if (sf_int%status >= SF_INITIAL) then allocate (k (size (E))) if (all (E**2 >= sf_int%mi2)) then do j = 1, size (E) k(j) = vector4_moving (E(j), & (3-2*j) * sqrt (E(j)**2 - sf_int%mi2(j)), 3) end do call sf_int%seed_kinematics (k) end if end if end subroutine sf_int_seed_energies @ %def sf_int_seed_momenta @ %def sf_int_seed_energies @ Tell if in generator mode. By default, this is false. To be overridden where appropriate; we may refer to the [[is_generator]] method of the [[data]] component in the concrete type. <>= procedure :: is_generator => sf_int_is_generator <>= function sf_int_is_generator (sf_int) result (flag) class(sf_int_t), intent(in) :: sf_int logical :: flag flag = .false. end function sf_int_is_generator @ %def sf_int_is_generator @ Generate free parameters [[r]]. Parameters are free if they do not correspond to integration parameters (i.e., are bound), but are generated by the structure function object itself. By default, all parameters are bound, and the output values of this procedure will be discarded. With free parameters, we have to override this procedure. The value [[x_free]] is the renormalization factor of the total energy that corresponds to the free parameters. If there are no free parameters, the procedure will not change its value, which starts as unity. Otherwise, the fraction is typically decreased, but may also be increased in some cases. <>= procedure :: generate_free => sf_int_generate_free <>= subroutine sf_int_generate_free (sf_int, r, rb, x_free) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free r = 0 rb= 1 end subroutine sf_int_generate_free @ %def sf_int_generate_free @ Complete the structure-function kinematics, derived from an input parameter (array) $r$ between 0 and 1. The interaction momenta are calculated, and we return $x$ (the momentum fraction), and $f$ (the Jacobian factor for the map $r\to x$), if [[map]] is set. If the [[map]] flag is unset, $r$ and $x$ values will coincide, and $f$ will become unity. If it is set, the structure-function implementation chooses a convenient mapping from $r$ to $x$ with Jacobian $f$. In the [[inverse_kinematics]] variant, we exchange the intent of [[x]] and [[r]]. The momenta are calculated only if the optional flag [[set_momenta]] is present and set. Internal parameters of [[sf_int]] are calculated only if the optional flag [[set_x]] is present and set. Update 2018-08-22: Throughout this algorithm, we now carry [[xb]]=$1-x$ together with [[x]] values, as we did for [[r]] before. This allows us to handle unstable endpoint numerics wherever necessary. The only place where the changes actually did matter was for inverse kinematics in the ISR setup, with a very soft photon, but it might be most sensible to apply the extension with [[xb]] everywhere. <>= procedure (sf_int_complete_kinematics), deferred :: complete_kinematics procedure (sf_int_inverse_kinematics), deferred :: inverse_kinematics <>= abstract interface subroutine sf_int_complete_kinematics (sf_int, x, xb, f, r, rb, map) import class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine sf_int_complete_kinematics end interface abstract interface subroutine sf_int_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) import class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine sf_int_inverse_kinematics end interface @ %def sf_int_complete_kinematics @ %def sf_int_inverse_kinematics @ Single splitting: compute momenta, given $x$ input parameters. We assume that the incoming momentum is set. The status code is set to [[SF_FAILED_KINEMATICS]] if the $x$ array does not correspond to a valid momentum configuration. Otherwise, it is updated to [[SF_DONE_KINEMATICS]]. We force the outgoing particle on-shell. The on-shell projection is determined by the [[on_shell_mode]]. The radiated particle should already be on shell. <>= procedure :: split_momentum => sf_int_split_momentum <>= subroutine sf_int_split_momentum (sf_int, x, xb) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(vector4_t) :: k type(vector4_t), dimension(2) :: q type(splitting_data_t) :: sd real(default) :: E1, E2 logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then k = sf_int%get_momentum (1) call sd%init (k, & sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), & collinear = size (x) == 1) call sd%set_t_bounds (x(1), xb(1)) select case (size (x)) case (1) case (3) if (sf_int%qmax_defined) then if (sf_int%qmin_defined) then call sd%sample_t (x(2), & t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2) else call sd%sample_t (x(2), & t0 = - sf_int%qmax(1) ** 2) end if else if (sf_int%qmin_defined) then call sd%sample_t (x(2), t1 = - sf_int%qmin(1) ** 2) else call sd%sample_t (x(2)) end if end if call sd%sample_phi (x(3)) case default call msg_bug ("Structure function: impossible number of parameters") end select q = sd%split_momentum (k) call on_shell (q, [sf_int%mr2, sf_int%mo2], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E1 = energy (q(1)) E2 = energy (q(2)) fail = E1 < 0 .or. E2 < 0 & .or. E1 ** 2 < sf_int%mr2(1) & .or. E2 ** 2 < sf_int%mo2(1) if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_split_momentum @ %def sf_test_split_momentum @ Pair splitting: two incoming momenta, two radiated, two outgoing. This is simple because we insist on all momenta being collinear. <>= procedure :: split_momenta => sf_int_split_momenta <>= subroutine sf_int_split_momenta (sf_int, x, xb) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(vector4_t), dimension(2) :: k type(vector4_t), dimension(4) :: q real(default), dimension(4) :: E logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then select case (size (x)) case (2) case default call msg_bug ("Pair structure function: recoil requested & &but not implemented yet") end select k(1) = sf_int%get_momentum (1) k(2) = sf_int%get_momentum (2) q(1:2) = xb * k q(3:4) = x * k select case (size (sf_int%mr2)) case (2) call on_shell (q, & [sf_int%mr2(1), sf_int%mr2(2), & sf_int%mo2(1), sf_int%mo2(2)], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E = energy (q) fail = any (E < 0) & .or. any (E(1:2) ** 2 < sf_int%mr2) & .or. any (E(3:4) ** 2 < sf_int%mo2) case default; call msg_bug ("split momenta: incorrect use") end select if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_split_momenta @ %def sf_int_split_momenta @ Pair spectrum: the reduced version of the previous splitting, without radiated momenta. <>= procedure :: reduce_momenta => sf_int_reduce_momenta <>= subroutine sf_int_reduce_momenta (sf_int, x) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default), dimension(2) :: E logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then select case (size (x)) case (2) case default call msg_bug ("Pair spectrum: recoil requested & &but not implemented yet") end select k(1) = sf_int%get_momentum (1) k(2) = sf_int%get_momentum (2) q = x * k call on_shell (q, & [sf_int%mo2(1), sf_int%mo2(2)], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E = energy (q) fail = any (E < 0) & .or. any (E ** 2 < sf_int%mo2) if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_reduce_momenta @ %def sf_int_reduce_momenta @ The inverse procedure: we compute the [[x]] array from the momentum configuration. In an overriding TBP, we may also set internal data that depend on this, for convenience. NOTE: Here and above, the single-particle case is treated in detail, allowing for non-collinearity and non-vanishing masses and nontrivial momentum-transfer bounds. For the pair case, we currently implement only collinear splitting and assume massless particles. This should be improved. Update 2017-08-22: recover also [[xb]], using the updated [[recover]] method of the splitting-data object. Th <>= procedure :: recover_x => sf_int_recover_x procedure :: base_recover_x => sf_int_recover_x <>= subroutine sf_int_recover_x (sf_int, x, xb, x_free) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free type(vector4_t), dimension(:), allocatable :: k type(vector4_t), dimension(:), allocatable :: q type(splitting_data_t) :: sd if (sf_int%status >= SF_SEED_KINEMATICS) then allocate (k (sf_int%interaction_t%get_n_in ())) allocate (q (sf_int%interaction_t%get_n_out ())) k = sf_int%get_momenta (outgoing=.false.) q = sf_int%get_momenta (outgoing=.true.) select case (size (k)) case (1) call sd%init (k(1), & sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), & collinear = size (x) == 1) call sd%recover (k(1), q, sf_int%on_shell_mode) x(1) = sd%get_x () xb(1) = sd%get_xb () select case (size (x)) case (1) case (3) if (sf_int%qmax_defined) then if (sf_int%qmin_defined) then call sd%inverse_t (x(2), & t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2) else call sd%inverse_t (x(2), & t0 = - sf_int%qmax(1) ** 2) end if else if (sf_int%qmin_defined) then call sd%inverse_t (x(2), t1 = - sf_int%qmin(1) ** 2) else call sd%inverse_t (x(2)) end if end if call sd%inverse_phi (x(3)) xb(2:3) = 1 - x(2:3) case default call msg_bug ("Structure function: impossible number & &of parameters") end select case (2) select case (size (x)) case (2) case default call msg_bug ("Pair structure function: recoil requested & &but not implemented yet") end select select case (sf_int%on_shell_mode) case (KEEP_ENERGY) select case (size (q)) case (4) x = energy (q(3:4)) / energy (k) xb= energy (q(1:2)) / energy (k) case (2) x = energy (q) / energy (k) xb= 1 - x end select case (KEEP_MOMENTUM) select case (size (q)) case (4) x = longitudinal_part (q(3:4)) / longitudinal_part (k) xb= longitudinal_part (q(1:2)) / longitudinal_part (k) case (2) x = longitudinal_part (q) / longitudinal_part (k) xb= 1 - x end select end select end select end if end subroutine sf_int_recover_x @ %def sf_int_recover_x @ Apply the structure function, i.e., evaluate the interaction. For the calculation, we may use the stored momenta, any further information stored inside the [[sf_int]] implementation during kinematics setup, and the given energy scale. It may happen that for the given kinematics the value is not defined. This should be indicated by the status code. <>= procedure (sf_int_apply), deferred :: apply <>= abstract interface subroutine sf_int_apply (sf_int, scale, negative_sf, rescale, i_sub) import class(sf_int_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine sf_int_apply end interface @ %def sf_int_apply @ \subsection{Accessing the structure function} Return metadata. Once [[interaction_t]] is rewritten in OO, some of this will be inherited. The number of outgoing particles is equal to the number of incoming particles. The radiated particles are the difference. <>= procedure :: get_n_in => sf_int_get_n_in procedure :: get_n_rad => sf_int_get_n_rad procedure :: get_n_out => sf_int_get_n_out <>= pure function sf_int_get_n_in (object) result (n_in) class(sf_int_t), intent(in) :: object integer :: n_in n_in = object%interaction_t%get_n_in () end function sf_int_get_n_in pure function sf_int_get_n_rad (object) result (n_rad) class(sf_int_t), intent(in) :: object integer :: n_rad n_rad = object%interaction_t%get_n_out () & - object%interaction_t%get_n_in () end function sf_int_get_n_rad pure function sf_int_get_n_out (object) result (n_out) class(sf_int_t), intent(in) :: object integer :: n_out n_out = object%interaction_t%get_n_in () end function sf_int_get_n_out @ %def sf_int_get_n_in @ %def sf_int_get_n_rad @ %def sf_int_get_n_out @ Number of matrix element entries in the interaction: <>= procedure :: get_n_states => sf_int_get_n_states <>= function sf_int_get_n_states (sf_int) result (n_states) class(sf_int_t), intent(in) :: sf_int integer :: n_states n_states = sf_int%get_n_matrix_elements () end function sf_int_get_n_states @ %def sf_int_get_n_states @ Return a specific state as a quantum-number array. <>= procedure :: get_state => sf_int_get_state <>= function sf_int_get_state (sf_int, i) result (qn) class(sf_int_t), intent(in) :: sf_int type(quantum_numbers_t), dimension(:), allocatable :: qn integer, intent(in) :: i allocate (qn (sf_int%get_n_tot ())) qn = sf_int%get_quantum_numbers (i) end function sf_int_get_state @ %def sf_int_get_state @ Return the matrix-element values for all states. We can assume that the matrix elements are real, so we take the real part. <>= procedure :: get_values => sf_int_get_values <>= subroutine sf_int_get_values (sf_int, value) class(sf_int_t), intent(in) :: sf_int real(default), dimension(:), intent(out) :: value integer :: i if (sf_int%status >= SF_EVALUATED) then do i = 1, size (value) value(i) = real (sf_int%get_matrix_element (i)) end do else value = 0 end if end subroutine sf_int_get_values @ %def sf_int_get_values @ \subsection{Direct calculations} Compute a structure function value (array) directly, given an array of $x$ values and a scale. If the energy is also given, we initialize the kinematics for that energy, otherwise take it from a previous run. We assume that the [[E]] array has dimension [[n_in]], and the [[x]] array has [[n_par]]. Note: the output x values ([[xx]] and [[xxb]]) are unused in this use case. <>= procedure :: compute_values => sf_int_compute_values <>= subroutine sf_int_compute_values (sf_int, value, x, xb, scale, E) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: value real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(in) :: scale real(default), dimension(:), intent(in), optional :: E real(default), dimension(size (x)) :: xx, xxb real(default) :: f if (present (E)) call sf_int%seed_kinematics (E) if (sf_int%status >= SF_SEED_KINEMATICS) then call sf_int%complete_kinematics (xx, xxb, f, x, xb, map=.false.) call sf_int%apply (scale) call sf_int%get_values (value) value = value * f else value = 0 end if end subroutine sf_int_compute_values @ %def sf_int_compute_values @ Compute just a single value for one of the states, i.e., throw the others away. <>= procedure :: compute_value => sf_int_compute_value <>= subroutine sf_int_compute_value & (sf_int, i_state, value, x, xb, scale, E) class(sf_int_t), intent(inout) :: sf_int integer, intent(in) :: i_state real(default), intent(out) :: value real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(in) :: scale real(default), dimension(:), intent(in), optional :: E real(default), dimension(:), allocatable :: value_array if (sf_int%status >= SF_INITIAL) then allocate (value_array (sf_int%get_n_states ())) call sf_int%compute_values (value_array, x, xb, scale, E) value = value_array(i_state) else value = 0 end if end subroutine sf_int_compute_value @ %def sf_int_compute_value @ \subsection{Structure-function instance} This is a wrapper for [[sf_int_t]] objects, such that we can build an array with different structure-function types. The structure-function contains an array (a sequence) of [[sf_int_t]] objects. The object, it holds the evaluator that connects the preceding part of the structure-function chain to the current interaction. It also stores the input and output parameter values for the contained structure function. The [[r]] array has a second dimension, corresponding to the mapping channels in a multi-channel configuration. There is a Jacobian entry [[f]] for each channel. The corresponding logical array [[mapping]] tells whether we apply the mapping appropriate for the current structure function in this channel. The [[x]] parameter values (energy fractions) are common to all channels. <>= type :: sf_instance_t class(sf_int_t), allocatable :: int type(evaluator_t) :: eval real(default), dimension(:,:), allocatable :: r real(default), dimension(:,:), allocatable :: rb real(default), dimension(:), allocatable :: f logical, dimension(:), allocatable :: m real(default), dimension(:), allocatable :: x real(default), dimension(:), allocatable :: xb end type sf_instance_t @ %def sf_instance_t @ \subsection{Structure-function chain} A chain is an array of structure functions [[sf]], initiated by a beam setup. We do not use this directly for evaluation, but create instances with copies of the contained interactions. [[n_par]] is the total number of parameters that is necessary for completely determining the structure-function chain. [[n_bound]] is the number of MC input parameters that are requested from the integrator. The difference of [[n_par]] and [[n_bound]] is the number of free parameters, which are generated by a structure-function object in generator mode. <>= public :: sf_chain_t <>= type, extends (beam_t) :: sf_chain_t type(beam_data_t), pointer :: beam_data => null () integer :: n_in = 0 integer :: n_strfun = 0 integer :: n_par = 0 integer :: n_bound = 0 type(sf_instance_t), dimension(:), allocatable :: sf logical :: trace_enable = .false. integer :: trace_unit = 0 contains <> end type sf_chain_t @ %def sf_chain_t @ Finalizer. <>= procedure :: final => sf_chain_final <>= subroutine sf_chain_final (object) class(sf_chain_t), intent(inout) :: object integer :: i call object%final_tracing () if (allocated (object%sf)) then do i = 1, size (object%sf, 1) associate (sf => object%sf(i)) if (allocated (sf%int)) then call sf%int%final () end if end associate end do end if call beam_final (object%beam_t) end subroutine sf_chain_final @ %def sf_chain_final @ Output. <>= procedure :: write => sf_chain_write <>= subroutine sf_chain_write (object, unit) class(sf_chain_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Incoming particles / structure-function chain:" if (associated (object%beam_data)) then write (u, "(3x,A,I0)") "n_in = ", object%n_in write (u, "(3x,A,I0)") "n_strfun = ", object%n_strfun write (u, "(3x,A,I0)") "n_par = ", object%n_par if (object%n_par /= object%n_bound) then write (u, "(3x,A,I0)") "n_bound = ", object%n_bound end if call object%beam_data%write (u) call write_separator (u) call beam_write (object%beam_t, u) if (allocated (object%sf)) then do i = 1, object%n_strfun associate (sf => object%sf(i)) call write_separator (u) if (allocated (sf%int)) then call sf%int%write (u) else write (u, "(1x,A)") "SF instance: [undefined]" end if end associate end do end if else write (u, "(3x,A)") "[undefined]" end if end subroutine sf_chain_write @ %def sf_chain_write @ Initialize: setup beams. The [[beam_data]] target must remain valid for the lifetime of the chain, since we just establish a pointer. The structure-function configuration array is used to initialize the individual structure-function entries. The target attribute is needed because the [[sf_int]] entries establish pointers to the configuration data. <>= procedure :: init => sf_chain_init <>= subroutine sf_chain_init (sf_chain, beam_data, sf_config) class(sf_chain_t), intent(out) :: sf_chain type(beam_data_t), intent(in), target :: beam_data type(sf_config_t), dimension(:), intent(in), optional, target :: sf_config integer :: i sf_chain%beam_data => beam_data sf_chain%n_in = beam_data%get_n_in () call beam_init (sf_chain%beam_t, beam_data) if (present (sf_config)) then sf_chain%n_strfun = size (sf_config) allocate (sf_chain%sf (sf_chain%n_strfun)) do i = 1, sf_chain%n_strfun call sf_chain%set_strfun (i, sf_config(i)%i, sf_config(i)%data) end do end if end subroutine sf_chain_init @ %def sf_chain_init @ Receive the beam momenta from a source to which the beam interaction is linked. <>= procedure :: receive_beam_momenta => sf_chain_receive_beam_momenta <>= subroutine sf_chain_receive_beam_momenta (sf_chain) class(sf_chain_t), intent(inout), target :: sf_chain type(interaction_t), pointer :: beam_int beam_int => sf_chain%get_beam_int_ptr () call beam_int%receive_momenta () end subroutine sf_chain_receive_beam_momenta @ %def sf_chain_receive_beam_momenta @ Explicitly set the beam momenta. <>= procedure :: set_beam_momenta => sf_chain_set_beam_momenta <>= subroutine sf_chain_set_beam_momenta (sf_chain, p) class(sf_chain_t), intent(inout) :: sf_chain type(vector4_t), dimension(:), intent(in) :: p call beam_set_momenta (sf_chain%beam_t, p) end subroutine sf_chain_set_beam_momenta @ %def sf_chain_set_beam_momenta @ Set a structure-function entry. We use the [[data]] input to allocate the [[int]] structure-function instance with appropriate type, then initialize the entry. The entry establishes a pointer to [[data]]. The index [[i]] is the structure-function index in the chain. <>= procedure :: set_strfun => sf_chain_set_strfun <>= subroutine sf_chain_set_strfun (sf_chain, i, beam_index, data) class(sf_chain_t), intent(inout) :: sf_chain integer, intent(in) :: i integer, dimension(:), intent(in) :: beam_index class(sf_data_t), intent(in), target :: data integer :: n_par, j n_par = data%get_n_par () call data%allocate_sf_int (sf_chain%sf(i)%int) associate (sf_int => sf_chain%sf(i)%int) call sf_int%init (data) call sf_int%set_beam_index (beam_index) call sf_int%set_par_index & ([(j, j = sf_chain%n_par + 1, sf_chain%n_par + n_par)]) sf_chain%n_par = sf_chain%n_par + n_par if (.not. data%is_generator ()) then sf_chain%n_bound = sf_chain%n_bound + n_par end if end associate end subroutine sf_chain_set_strfun @ %def sf_chain_set_strfun @ Return the number of structure-function parameters. <>= procedure :: get_n_par => sf_chain_get_n_par procedure :: get_n_bound => sf_chain_get_n_bound <>= function sf_chain_get_n_par (sf_chain) result (n) class(sf_chain_t), intent(in) :: sf_chain integer :: n n = sf_chain%n_par end function sf_chain_get_n_par function sf_chain_get_n_bound (sf_chain) result (n) class(sf_chain_t), intent(in) :: sf_chain integer :: n n = sf_chain%n_bound end function sf_chain_get_n_bound @ %def sf_chain_get_n_par @ %def sf_chain_get_n_bound @ Return a pointer to the beam interaction. <>= procedure :: get_beam_int_ptr => sf_chain_get_beam_int_ptr <>= function sf_chain_get_beam_int_ptr (sf_chain) result (int) type(interaction_t), pointer :: int class(sf_chain_t), intent(in), target :: sf_chain int => beam_get_int_ptr (sf_chain%beam_t) end function sf_chain_get_beam_int_ptr @ %def sf_chain_get_beam_int_ptr @ Enable the trace feature: record structure function data (input parameters, $x$ values, evaluation result) to an external file. <>= procedure :: setup_tracing => sf_chain_setup_tracing procedure :: final_tracing => sf_chain_final_tracing <>= subroutine sf_chain_setup_tracing (sf_chain, file) class(sf_chain_t), intent(inout) :: sf_chain type(string_t), intent(in) :: file if (sf_chain%n_strfun > 0) then sf_chain%trace_enable = .true. sf_chain%trace_unit = free_unit () open (sf_chain%trace_unit, file = char (file), action = "write", & status = "replace") call sf_chain%write_trace_header () else call msg_error ("Beam structure: no structure functions, tracing & &disabled") end if end subroutine sf_chain_setup_tracing subroutine sf_chain_final_tracing (sf_chain) class(sf_chain_t), intent(inout) :: sf_chain if (sf_chain%trace_enable) then close (sf_chain%trace_unit) sf_chain%trace_enable = .false. end if end subroutine sf_chain_final_tracing @ %def sf_chain_setup_tracing @ %def sf_chain_final_tracing @ Write the header for the tracing file. <>= procedure :: write_trace_header => sf_chain_write_trace_header <>= subroutine sf_chain_write_trace_header (sf_chain) class(sf_chain_t), intent(in) :: sf_chain integer :: u if (sf_chain%trace_enable) then u = sf_chain%trace_unit write (u, "('# ',A)") "WHIZARD output: & &structure-function sampling data" write (u, "('# ',A,1x,I0)") "Number of sf records:", sf_chain%n_strfun write (u, "('# ',A,1x,I0)") "Number of parameters:", sf_chain%n_par write (u, "('# ',A)") "Columns: channel, p(n_par), x(n_par), f, Jac * f" end if end subroutine sf_chain_write_trace_header @ %def sf_chain_write_trace_header @ Write a record which collects the structure function data for the current data point. For the selected channel, we print first the input integration parameters, then the $x$ values, then the structure-function value summed over all quantum numbers, then the structure function value times the mapping Jacobian. <>= procedure :: trace => sf_chain_trace <>= subroutine sf_chain_trace (sf_chain, c_sel, p, x, f, sf_sum) class(sf_chain_t), intent(in) :: sf_chain integer, intent(in) :: c_sel real(default), dimension(:,:), intent(in) :: p real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: f real(default), intent(in) :: sf_sum real(default) :: sf_sum_pac, f_sf_sum_pac integer :: u, i if (sf_chain%trace_enable) then u = sf_chain%trace_unit write (u, "(1x,I0)", advance="no") c_sel write (u, "(2x)", advance="no") do i = 1, sf_chain%n_par write (u, "(1x," // FMT_17 // ")", advance="no") p(i,c_sel) end do write (u, "(2x)", advance="no") do i = 1, sf_chain%n_par write (u, "(1x," // FMT_17 // ")", advance="no") x(i) end do write (u, "(2x)", advance="no") sf_sum_pac = sf_sum f_sf_sum_pac = f(c_sel) * sf_sum call pacify (sf_sum_pac, 1.E-28_default) call pacify (f_sf_sum_pac, 1.E-28_default) write (u, "(2(1x," // FMT_17 // "))") sf_sum_pac, f_sf_sum_pac end if end subroutine sf_chain_trace @ %def sf_chain_trace @ \subsection{Chain instances} A structure-function chain instance contains copies of the interactions in the configuration chain, suitably linked to each other and connected by evaluators. After initialization, [[out_sf]] should point, for each beam, to the last structure function that affects this beam. [[out_sf_i]] should indicate the index of the corresponding outgoing particle within that structure-function interaction. Analogously, [[out_eval]] is the last evaluator in the structure-function chain, which contains the complete set of outgoing particles. [[out_eval_i]] should indicate the index of the outgoing particles, within that evaluator, which will initiate the collision. When calculating actual kinematics, we fill the [[p]], [[r]], and [[x]] arrays and the [[f]] factor. The [[p]] array denotes the MC input parameters as they come from the random-number generator. The [[r]] array results from applying global mappings. The [[x]] array results from applying structure-function local mappings. The $x$ values can be interpreted directly as momentum fractions (or angle fractions, where recoil is involved). The [[f]] factor is the Jacobian that results from applying all mappings. Update 2017-08-22: carry and output all complements ([[pb]], [[rb]], [[xb]]). Previously, [[xb]] was not included in the record, and the output did not contain either. It does become more verbose, however. The [[mapping]] entry may store a global mapping that is applied to a combination of $x$ values and structure functions, as opposed to mappings that affect only a single structure function. It is applied before the latter mappings, in the transformation from the [[p]] array to the [[r]] array. For parameters affected by this mapping, we should ensure that they are not involved in a local mapping. <>= public :: sf_chain_instance_t <>= type, extends (beam_t) :: sf_chain_instance_t type(sf_chain_t), pointer :: config => null () integer :: status = SF_UNDEFINED type(sf_instance_t), dimension(:), allocatable :: sf integer, dimension(:), allocatable :: out_sf integer, dimension(:), allocatable :: out_sf_i integer :: out_eval = 0 integer, dimension(:), allocatable :: out_eval_i integer :: selected_channel = 0 real(default), dimension(:,:), allocatable :: p, pb real(default), dimension(:,:), allocatable :: r, rb real(default), dimension(:), allocatable :: f real(default), dimension(:), allocatable :: x, xb logical, dimension(:), allocatable :: bound real(default) :: x_free = 1 type(sf_channel_t), dimension(:), allocatable :: channel contains <> end type sf_chain_instance_t @ %def sf_chain_instance_t @ Finalizer. <>= procedure :: final => sf_chain_instance_final <>= subroutine sf_chain_instance_final (object) class(sf_chain_instance_t), intent(inout) :: object integer :: i if (allocated (object%sf)) then do i = 1, size (object%sf, 1) associate (sf => object%sf(i)) if (allocated (sf%int)) then call sf%eval%final () call sf%int%final () end if end associate end do end if call beam_final (object%beam_t) end subroutine sf_chain_instance_final @ %def sf_chain_instance_final @ Output. <>= procedure :: write => sf_chain_instance_write <>= subroutine sf_chain_instance_write (object, unit, col_verbose) class(sf_chain_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose integer :: u, i, c u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "Structure-function chain instance:" call write_sf_status (object%status, u) if (allocated (object%out_sf)) then write (u, "(3x,A)", advance="no") "outgoing (interactions) =" do i = 1, size (object%out_sf) write (u, "(1x,I0,':',I0)", advance="no") & object%out_sf(i), object%out_sf_i(i) end do write (u, *) end if if (object%out_eval /= 0) then write (u, "(3x,A)", advance="no") "outgoing (evaluators) =" do i = 1, size (object%out_sf) write (u, "(1x,I0,':',I0)", advance="no") & object%out_eval, object%out_eval_i(i) end do write (u, *) end if if (allocated (object%sf)) then if (size (object%sf) /= 0) then write (u, "(1x,A)") "Structure-function parameters:" do c = 1, size (object%f) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A,9(1x,F9.7))") "p =", object%p(:,c) write (u, "(3x,A,9(1x,F9.7))") "pb=", object%pb(:,c) write (u, "(3x,A,9(1x,F9.7))") "r =", object%r(:,c) write (u, "(3x,A,9(1x,F9.7))") "rb=", object%rb(:,c) write (u, "(3x,A,9(1x,ES13.7))") "f =", object%f(c) write (u, "(3x,A)", advance="no") "m =" call object%channel(c)%write (u) end do write (u, "(3x,A,9(1x,F9.7))") "x =", object%x write (u, "(3x,A,9(1x,F9.7))") "xb=", object%xb if (.not. all (object%bound)) then write (u, "(3x,A,9(1x,L1))") "bound =", object%bound end if end if end if call write_separator (u) call beam_write (object%beam_t, u, col_verbose = col_verbose) if (allocated (object%sf)) then do i = 1, size (object%sf) associate (sf => object%sf(i)) call write_separator (u) if (allocated (sf%int)) then if (allocated (sf%r)) then write (u, "(1x,A)") "Structure-function parameters:" do c = 1, size (sf%f) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A,9(1x,F9.7))") "r =", sf%r(:,c) write (u, "(3x,A,9(1x,F9.7))") "rb=", sf%rb(:,c) write (u, "(3x,A,9(1x,ES13.7))") "f =", sf%f(c) write (u, "(3x,A,9(1x,L1,7x))") "m =", sf%m(c) end do write (u, "(3x,A,9(1x,F9.7))") "x =", sf%x write (u, "(3x,A,9(1x,F9.7))") "xb=", sf%xb end if call sf%int%write(u) if (.not. sf%eval%is_empty ()) then call sf%eval%write (u, col_verbose = col_verbose) end if end if end associate end do end if end subroutine sf_chain_instance_write @ %def sf_chain_instance_write @ Initialize. This creates a copy of the interactions in the configuration chain, assumed to be properly initialized. In the copy, we allocate the [[p]] etc.\ arrays. The brute-force assignment of the [[sf]] component would be straightforward, but we provide a more fine-grained copy. In any case, the copy is deep as far as allocatables are concerned, but for the contained [[interaction_t]] objects the copy is shallow, as long as we do not bind defined assignment to the type. Therefore, we have to re-assign the [[interaction_t]] components explicitly, this time calling the proper defined assignment. Furthermore, we allocate the parameter arrays for each structure function. <>= procedure :: init => sf_chain_instance_init <>= subroutine sf_chain_instance_init (chain, config, n_channel) class(sf_chain_instance_t), intent(out), target :: chain type(sf_chain_t), intent(in), target :: config integer, intent(in) :: n_channel integer :: i, j integer :: n_par_tot, n_par, n_strfun chain%config => config n_strfun = config%n_strfun chain%beam_t = config%beam_t allocate (chain%out_sf (config%n_in), chain%out_sf_i (config%n_in)) allocate (chain%out_eval_i (config%n_in)) chain%out_sf = 0 chain%out_sf_i = [(i, i = 1, config%n_in)] chain%out_eval_i = chain%out_sf_i n_par_tot = 0 if (n_strfun /= 0) then allocate (chain%sf (n_strfun)) do i = 1, n_strfun associate (sf => chain%sf(i)) allocate (sf%int, source=config%sf(i)%int) sf%int%interaction_t = config%sf(i)%int%interaction_t n_par = size (sf%int%par_index) allocate (sf%r (n_par, n_channel)); sf%r = 0 allocate (sf%rb(n_par, n_channel)); sf%rb= 0 allocate (sf%f (n_channel)); sf%f = 0 allocate (sf%m (n_channel)); sf%m = .false. allocate (sf%x (n_par)); sf%x = 0 allocate (sf%xb(n_par)); sf%xb= 0 n_par_tot = n_par_tot + n_par end associate end do allocate (chain%p (n_par_tot, n_channel)); chain%p = 0 allocate (chain%pb(n_par_tot, n_channel)); chain%pb= 0 allocate (chain%r (n_par_tot, n_channel)); chain%r = 0 allocate (chain%rb(n_par_tot, n_channel)); chain%rb= 0 allocate (chain%f (n_channel)); chain%f = 0 allocate (chain%x (n_par_tot)); chain%x = 0 allocate (chain%xb(n_par_tot)); chain%xb= 0 call allocate_sf_channels & (chain%channel, n_channel=n_channel, n_strfun=n_strfun) end if allocate (chain%bound (n_par_tot), source = .true.) do i = 1, n_strfun associate (sf => chain%sf(i)) if (sf%int%is_generator ()) then do j = 1, size (sf%int%par_index) chain%bound(sf%int%par_index(j)) = .false. end do end if end associate end do chain%status = SF_INITIAL end subroutine sf_chain_instance_init @ %def sf_chain_instance_init @ Manually select a channel. <>= procedure :: select_channel => sf_chain_instance_select_channel <>= subroutine sf_chain_instance_select_channel (chain, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in), optional :: channel if (present (channel)) then chain%selected_channel = channel else chain%selected_channel = 0 end if end subroutine sf_chain_instance_select_channel @ %def sf_chain_instance_select_channel @ Copy a channel-mapping object to the structure-function chain instance. We assume that assignment is sufficient, i.e., any non-static components of the [[channel]] object are allocatable und thus recursively copied. After the copy, we extract the single-entry mappings and activate them for the individual structure functions. If there is a multi-entry mapping, we obtain the corresponding MC parameter indices and set them in the copy of the channel object. <>= procedure :: set_channel => sf_chain_instance_set_channel <>= subroutine sf_chain_instance_set_channel (chain, c, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in) :: c type(sf_channel_t), intent(in) :: channel integer :: i, j, k if (chain%status >= SF_INITIAL) then chain%channel(c) = channel j = 0 do i = 1, chain%config%n_strfun associate (sf => chain%sf(i)) sf%m(c) = channel%is_single_mapping (i) if (channel%is_multi_mapping (i)) then do k = 1, size (sf%int%beam_index) j = j + 1 call chain%channel(c)%set_par_index & (j, sf%int%par_index(k)) end do end if end associate end do if (j /= chain%channel(c)%get_multi_mapping_n_par ()) then print *, "index last filled = ", j print *, "number of parameters = ", & chain%channel(c)%get_multi_mapping_n_par () call msg_bug ("Structure-function setup: mapping index mismatch") end if chain%status = SF_INITIAL end if end subroutine sf_chain_instance_set_channel @ %def sf_chain_instance_set_channel @ Link the interactions in the chain. First, link the beam instance to its template in the configuration chain, which should have the appropriate momenta fixed. Then, we follow the chain via the arrays [[out_sf]] and [[out_sf_i]]. The arrays are (up to) two-dimensional, the entries correspond to the beam particle(s). For each beam, the entry [[out_sf]] points to the last interaction that affected this beam, and [[out_sf_i]] is the out-particle index within that interaction. For the initial beam, [[out_sf]] is zero by definition. For each entry in the chain, we scan the affected beams (one or two). We look for [[out_sf]] and link the out-particle there to the corresponding in-particle in the current interaction. Then, we update the entry in [[out_sf]] and [[out_sf_i]] to point to the current interaction. <>= procedure :: link_interactions => sf_chain_instance_link_interactions <>= subroutine sf_chain_instance_link_interactions (chain) class(sf_chain_instance_t), intent(inout), target :: chain type(interaction_t), pointer :: int integer :: i, j, b if (chain%status >= SF_INITIAL) then do b = 1, chain%config%n_in int => beam_get_int_ptr (chain%beam_t) call interaction_set_source_link (int, b, & chain%config%beam_t, b) end do if (allocated (chain%sf)) then do i = 1, size (chain%sf) associate (sf_int => chain%sf(i)%int) do j = 1, size (sf_int%beam_index) b = sf_int%beam_index(j) call link (sf_int%interaction_t, b, sf_int%incoming(j)) chain%out_sf(b) = i chain%out_sf_i(b) = sf_int%outgoing(j) end do end associate end do end if chain%status = SF_DONE_LINKS end if contains subroutine link (int, b, in_index) type(interaction_t), intent(inout) :: int integer, intent(in) :: b, in_index integer :: i i = chain%out_sf(b) select case (i) case (0) call interaction_set_source_link (int, in_index, & chain%beam_t, chain%out_sf_i(b)) case default call int%set_source_link (in_index, & chain%sf(i)%int, chain%out_sf_i(b)) end select end subroutine link end subroutine sf_chain_instance_link_interactions @ %def sf_chain_instance_link_interactions @ Exchange the quantum-number masks between the interactions in the chain, so we can combine redundant entries and detect any obvious mismatch. We proceed first in the forward direction and then backwards again. After this is finished, we finalize initialization by calling the [[setup_constants]] method, which prepares constant data that depend on the matrix element structure. <>= procedure :: exchange_mask => sf_chain_exchange_mask <>= subroutine sf_chain_exchange_mask (chain) class(sf_chain_instance_t), intent(inout), target :: chain type(interaction_t), pointer :: int type(quantum_numbers_mask_t), dimension(:), allocatable :: mask integer :: i if (chain%status >= SF_DONE_LINKS) then if (allocated (chain%sf)) then int => beam_get_int_ptr (chain%beam_t) allocate (mask (int%get_n_out ())) mask = int%get_mask () if (size (chain%sf) /= 0) then do i = 1, size (chain%sf) - 1 call interaction_exchange_mask (chain%sf(i)%int%interaction_t) end do do i = size (chain%sf), 1, -1 call interaction_exchange_mask (chain%sf(i)%int%interaction_t) end do if (any (mask .neqv. int%get_mask ())) then chain%status = SF_FAILED_MASK return end if do i = 1, size (chain%sf) call chain%sf(i)%int%setup_constants () end do end if end if chain%status = SF_DONE_MASK end if end subroutine sf_chain_exchange_mask @ %def sf_chain_exchange_mask @ Initialize the evaluators that connect the interactions in the chain. <>= procedure :: init_evaluators => sf_chain_instance_init_evaluators <>= subroutine sf_chain_instance_init_evaluators (chain, extended_sf) class(sf_chain_instance_t), intent(inout), target :: chain logical, intent(in), optional :: extended_sf type(interaction_t), pointer :: int type(quantum_numbers_mask_t) :: mask integer :: i logical :: yorn yorn = .false.; if (present (extended_sf)) yorn = extended_sf if (chain%status >= SF_DONE_MASK) then if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then mask = quantum_numbers_mask (.false., .false., .true.) int => beam_get_int_ptr (chain%beam_t) do i = 1, size (chain%sf) associate (sf => chain%sf(i)) if (yorn) then if (int%get_n_sub () == 0) then call int%declare_subtraction (n_beams_rescaled) end if if (sf%int%interaction_t%get_n_sub () == 0) then call sf%int%interaction_t%declare_subtraction (n_beams_rescaled) end if end if call sf%eval%init_product (int, sf%int%interaction_t, mask,& & ignore_sub_for_qn = .true.) if (sf%eval%is_empty ()) then chain%status = SF_FAILED_CONNECTIONS return end if int => sf%eval%interaction_t end associate end do call find_outgoing_particles () end if else if (chain%out_eval == 0) then int => beam_get_int_ptr (chain%beam_t) call int%tag_hard_process () end if chain%status = SF_DONE_CONNECTIONS end if contains <> end subroutine sf_chain_instance_init_evaluators @ %def sf_chain_instance_init_evaluators @ For debug purposes <>= procedure :: write_interaction => sf_chain_instance_write_interaction <>= subroutine sf_chain_instance_write_interaction (chain, i_sf, i_int, unit) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: i_sf, i_int integer, intent(in) :: unit class(interaction_t), pointer :: int_in1 => null () class(interaction_t), pointer :: int_in2 => null () integer :: u u = given_output_unit (unit); if (u < 0) return if (chain%status >= SF_DONE_MASK) then if (allocated (chain%sf)) then int_in1 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 1) int_in2 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 2) if (int_in1%get_tag () == i_int) then call int_in1%basic_write (u) else if (int_in2%get_tag () == i_int) then call int_in2%basic_write (u) else write (u, "(A,1x,I0,1x,A,1x,I0)") 'No tag of sf', i_sf, 'matches' , i_int end if else write (u, "(A)") 'No sf_chain allocated!' end if else write (u, "(A)") 'sf_chain not ready!' end if end subroutine sf_chain_instance_write_interaction @ %def sf_chain_instance_write_interaction @ This is an internal subroutine of the previous one: After evaluators are set, trace the outgoing particles to the last evaluator. We only need the first channel, all channels are equivalent for this purpose. For each beam, the outgoing particle is located by [[out_sf]] (the structure-function object where it originates) and [[out_sf_i]] (the index within that object). This particle is referenced by the corresponding evaluator, which in turn is referenced by the next evaluator, until we are at the end of the chain. We can trace back references by [[interaction_find_link]]. Knowing that [[out_eval]] is the index of the last evaluator, we thus determine [[out_eval_i]], the index of the outgoing particle within that evaluator. <>= subroutine find_outgoing_particles () type(interaction_t), pointer :: int, int_next integer :: i, j, out_sf, out_i chain%out_eval = size (chain%sf) do j = 1, size (chain%out_eval_i) out_sf = chain%out_sf(j) out_i = chain%out_sf_i(j) if (out_sf == 0) then int => beam_get_int_ptr (chain%beam_t) out_sf = 1 else int => chain%sf(out_sf)%int%interaction_t end if do i = out_sf, chain%out_eval int_next => chain%sf(i)%eval%interaction_t out_i = interaction_find_link (int_next, int, out_i) int => int_next end do chain%out_eval_i(j) = out_i end do call int%tag_hard_process (chain%out_eval_i) end subroutine find_outgoing_particles @ %def find_outgoing_particles @ Compute the kinematics in the chain instance. We can assume that the seed momenta are set in the configuration beams. Scanning the chain, we first transfer the incoming momenta. Then, the use up the MC input parameter array [[p]] to compute the radiated and outgoing momenta. In the multi-channel case, [[c_sel]] is the channel which we use for computing the kinematics and the [[x]] values. In the other channels, we invert the kinematics in order to recover the corresponding rows in the [[r]] array, and the Jacobian [[f]]. We first apply any global mapping to transform the input [[p]] into the array [[r]]. This is then given to the structure functions which compute the final array [[x]] and Jacobian factors [[f]], which we multiply to obtain the overall Jacobian. <>= procedure :: compute_kinematics => sf_chain_instance_compute_kinematics <>= subroutine sf_chain_instance_compute_kinematics (chain, c_sel, p_in) class(sf_chain_instance_t), intent(inout), target :: chain integer, intent(in) :: c_sel real(default), dimension(:), intent(in) :: p_in type(interaction_t), pointer :: int real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel (c_sel) int => beam_get_int_ptr (chain%beam_t) call int%receive_momenta () if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%p (:,c_sel) = unpack (p_in, chain%bound, 0._default) chain%pb(:,c_sel) = 1 - chain%p(:,c_sel) chain%f = 1 chain%x_free = 1 do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%generate_free (sf%r(:,c_sel), sf%rb(:,c_sel), & chain%x_free) do j = 1, size (sf%x) if (.not. chain%bound(sf%int%par_index(j))) then chain%p (sf%int%par_index(j),c_sel) = sf%r (j,c_sel) chain%pb(sf%int%par_index(j),c_sel) = sf%rb(j,c_sel) end if end do end associate end do if (allocated (chain%channel(c_sel)%multi_mapping)) then call chain%channel(c_sel)%multi_mapping%compute & (chain%r(:,c_sel), chain%rb(:,c_sel), & f_mapping, & chain%p(:,c_sel), chain%pb(:,c_sel), & chain%x_free) chain%f(c_sel) = f_mapping else chain%r (:,c_sel) = chain%p (:,c_sel) chain%rb(:,c_sel) = chain%pb(:,c_sel) chain%f(c_sel) = 1 end if do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () do j = 1, size (sf%x) sf%r (j,c_sel) = chain%r (sf%int%par_index(j),c_sel) sf%rb(j,c_sel) = chain%rb(sf%int%par_index(j),c_sel) end do call sf%int%complete_kinematics & (sf%x, sf%xb, sf%f(c_sel), sf%r(:,c_sel), sf%rb(:,c_sel), & sf%m(c_sel)) do j = 1, size (sf%x) chain%x(sf%int%par_index(j)) = sf%x(j) chain%xb(sf%int%par_index(j)) = sf%xb(j) end do if (sf%int%status <= SF_FAILED_KINEMATICS) then chain%status = SF_FAILED_KINEMATICS return end if do c = 1, size (sf%f) if (c /= c_sel) then call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c)) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end if chain%f(c) = chain%f(c) * sf%f(c) end do if (.not. sf%eval%is_empty ()) then call sf%eval%receive_momenta () end if end associate end do do c = 1, size (chain%f) if (c /= c_sel) then if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_compute_kinematics @ %def sf_chain_instance_compute_kinematics @ This is a variant of the previous procedure. We know the $x$ parameters and reconstruct the momenta and the MC input parameters [[p]]. We do not need to select a channel. Note: this is probably redundant, since the method we actually want starts from the momenta, recovers all $x$ parameters, and then inverts mappings. See below [[recover_kinematics]]. <>= procedure :: inverse_kinematics => sf_chain_instance_inverse_kinematics <>= subroutine sf_chain_instance_inverse_kinematics (chain, x, xb) class(sf_chain_instance_t), intent(inout), target :: chain real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(interaction_t), pointer :: int real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel () int => beam_get_int_ptr (chain%beam_t) call int%receive_momenta () if (allocated (chain%sf)) then chain%f = 1 if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%x = x chain%xb= xb do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () do j = 1, size (sf%x) sf%x(j) = chain%x(sf%int%par_index(j)) sf%xb(j) = chain%xb(sf%int%par_index(j)) end do do c = 1, size (sf%f) call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), & set_momenta = c==1) chain%f(c) = chain%f(c) * sf%f(c) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end do if (.not. sf%eval%is_empty ()) then call sf%eval%receive_momenta () end if end associate end do do c = 1, size (chain%f) if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_inverse_kinematics @ %def sf_chain_instance_inverse_kinematics @ Recover the kinematics: assuming that the last evaluator has been filled with a valid set of momenta, we travel the momentum links backwards and fill the preceding evaluators and, as a side effect, interactions. We stop at the beam interaction. After all momenta are set, apply the [[inverse_kinematics]] procedure above, suitably modified, to recover the $x$ and $p$ parameters and the Jacobian factors. The [[c_sel]] (channel) argument is just used to mark a selected channel for the records, otherwise the recovery procedure is independent of this. <>= procedure :: recover_kinematics => sf_chain_instance_recover_kinematics <>= subroutine sf_chain_instance_recover_kinematics (chain, c_sel) class(sf_chain_instance_t), intent(inout), target :: chain integer, intent(in) :: c_sel real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel (c_sel) if (allocated (chain%sf)) then do i = size (chain%sf), 1, -1 associate (sf => chain%sf(i)) if (.not. sf%eval%is_empty ()) then call interaction_send_momenta (sf%eval%interaction_t) end if end associate end do chain%f = 1 if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%x_free = 1 do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () call sf%int%recover_x (sf%x, sf%xb, chain%x_free) do j = 1, size (sf%x) chain%x(sf%int%par_index(j)) = sf%x(j) chain%xb(sf%int%par_index(j)) = sf%xb(j) end do do c = 1, size (sf%f) call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), & set_momenta = .false.) chain%f(c) = chain%f(c) * sf%f(c) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end do end associate end do do c = 1, size (chain%f) if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_recover_kinematics @ %def sf_chain_instance_recover_kinematics @ Return the initial beam momenta to their source, thus completing kinematics recovery. Obviously, this works as a side effect. <>= procedure :: return_beam_momenta => sf_chain_instance_return_beam_momenta <>= subroutine sf_chain_instance_return_beam_momenta (chain) class(sf_chain_instance_t), intent(in), target :: chain type(interaction_t), pointer :: int if (chain%status >= SF_DONE_KINEMATICS) then int => beam_get_int_ptr (chain%beam_t) call interaction_send_momenta (int) end if end subroutine sf_chain_instance_return_beam_momenta @ %def sf_chain_instance_return_beam_momenta @ Evaluate all interactions in the chain and the product evaluators. We provide a [[scale]] argument that is given to all structure functions in the chain. Hadronic NLO calculations involve rescaled fractions of the original beam momentum. In particular, we have to handle the following cases: \begin{itemize} \item normal evaluation (where [[i_sub = 0]]) for all terms except the real non-subtracted, \item rescaled momentum fraction for both beams in the case of the real non-subtracted term ([[i_sub = 0]]), \item and rescaled momentum fraction for one of both beams in the case of the subtraction and DGLAP component ([[i_sub = 1,2]]). \end{itemize} For the collinear final or intial state counter terms, we apply a rescaling to one beam, and keep the other beam as is. We redo it then vice versa having now two subtractions. <>= procedure :: evaluate => sf_chain_instance_evaluate <>= subroutine sf_chain_instance_evaluate (chain, scale, negative_sf, sf_rescale) class(sf_chain_instance_t), intent(inout), target :: chain real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(inout), optional :: sf_rescale type(interaction_t), pointer :: out_int real(default) :: sf_sum integer :: i_beam, i_sub, n_sub logical :: rescale n_sub = 0 rescale = .false.; if (present (sf_rescale)) rescale = .true. if (rescale) then n_sub = chain%get_n_sub () end if if (chain%status >= SF_DONE_KINEMATICS) then if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then do i_beam = 1, size (chain%sf) associate (sf => chain%sf(i_beam)) if (rescale) then call sf_rescale%set_i_beam (i_beam) do i_sub = 0, n_sub select case (i_sub) case (0) if (n_sub == 0) then call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub) else call sf%int%apply (scale, negative_sf, i_sub = i_sub) end if case default if (i_beam == i_sub) then call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub) else call sf%int%apply (scale, negative_sf, i_sub = i_sub) end if end select end do else call sf%int%apply (scale, negative_sf, i_sub = n_sub) end if if (sf%int%status <= SF_FAILED_EVALUATION) then chain%status = SF_FAILED_EVALUATION return end if if (.not. sf%eval%is_empty ()) call sf%eval%evaluate () end associate end do out_int => chain%get_out_int_ptr () sf_sum = real (out_int%sum ()) call chain%config%trace & (chain%selected_channel, chain%p, chain%x, chain%f, sf_sum) end if end if chain%status = SF_EVALUATED end if end subroutine sf_chain_instance_evaluate @ %def sf_chain_instance_evaluate @ \subsection{Access to the chain instance} Transfer the outgoing momenta to the array [[p]]. We assume that array sizes match. <>= procedure :: get_out_momenta => sf_chain_instance_get_out_momenta <>= subroutine sf_chain_instance_get_out_momenta (chain, p) class(sf_chain_instance_t), intent(in), target :: chain type(vector4_t), dimension(:), intent(out) :: p type(interaction_t), pointer :: int integer :: i, j if (chain%status >= SF_DONE_KINEMATICS) then do j = 1, size (chain%out_sf) i = chain%out_sf(j) select case (i) case (0) int => beam_get_int_ptr (chain%beam_t) case default int => chain%sf(i)%int%interaction_t end select p(j) = int%get_momentum (chain%out_sf_i(j)) end do end if end subroutine sf_chain_instance_get_out_momenta @ %def sf_chain_instance_get_out_momenta @ Return a pointer to the last evaluator in the chain (to the interaction). <>= procedure :: get_out_int_ptr => sf_chain_instance_get_out_int_ptr <>= function sf_chain_instance_get_out_int_ptr (chain) result (int) class(sf_chain_instance_t), intent(in), target :: chain type(interaction_t), pointer :: int if (chain%out_eval == 0) then int => beam_get_int_ptr (chain%beam_t) else int => chain%sf(chain%out_eval)%eval%interaction_t end if end function sf_chain_instance_get_out_int_ptr @ %def sf_chain_instance_get_out_int_ptr @ Return the index of the [[j]]-th outgoing particle, within the last evaluator. <>= procedure :: get_out_i => sf_chain_instance_get_out_i <>= function sf_chain_instance_get_out_i (chain, j) result (i) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: j integer :: i i = chain%out_eval_i(j) end function sf_chain_instance_get_out_i @ %def sf_chain_instance_get_out_i @ Return the mask for the outgoing particle(s), within the last evaluator. <>= procedure :: get_out_mask => sf_chain_instance_get_out_mask <>= function sf_chain_instance_get_out_mask (chain) result (mask) class(sf_chain_instance_t), intent(in), target :: chain type(quantum_numbers_mask_t), dimension(:), allocatable :: mask type(interaction_t), pointer :: int allocate (mask (chain%config%n_in)) int => chain%get_out_int_ptr () mask = int%get_mask (chain%out_eval_i) end function sf_chain_instance_get_out_mask @ %def sf_chain_instance_get_out_mask @ Return the array of MC input parameters that corresponds to channel [[c]]. This is the [[p]] array, the parameters before all mappings. The [[p]] array may be deallocated. This should correspond to a zero-size [[r]] argument, so nothing to do then. <>= procedure :: get_mcpar => sf_chain_instance_get_mcpar <>= subroutine sf_chain_instance_get_mcpar (chain, c, r) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: c real(default), dimension(:), intent(out) :: r if (allocated (chain%p)) r = pack (chain%p(:,c), chain%bound) end subroutine sf_chain_instance_get_mcpar @ %def sf_chain_instance_get_mcpar @ Return the Jacobian factor that corresponds to channel [[c]]. <>= procedure :: get_f => sf_chain_instance_get_f <>= function sf_chain_instance_get_f (chain, c) result (f) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: c real(default) :: f if (allocated (chain%f)) then f = chain%f(c) else f = 1 end if end function sf_chain_instance_get_f @ %def sf_chain_instance_get_f @ Return the evaluation status. <>= procedure :: get_status => sf_chain_instance_get_status <>= function sf_chain_instance_get_status (chain) result (status) class(sf_chain_instance_t), intent(in) :: chain integer :: status status = chain%status end function sf_chain_instance_get_status @ %def sf_chain_instance_get_status @ <>= procedure :: get_matrix_elements => sf_chain_instance_get_matrix_elements <>= subroutine sf_chain_instance_get_matrix_elements (chain, i, ff) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: i real(default), intent(out), dimension(:), allocatable :: ff associate (sf => chain%sf(i)) ff = real (sf%int%get_matrix_element ()) end associate end subroutine sf_chain_instance_get_matrix_elements @ %def sf_chain_instance_get_matrix_elements @ <>= procedure :: get_beam_int_ptr => sf_chain_instance_get_beam_int_ptr <>= function sf_chain_instance_get_beam_int_ptr (chain) result (int) type(interaction_t), pointer :: int class(sf_chain_instance_t), intent(in), target :: chain int => beam_get_int_ptr (chain%beam_t) end function sf_chain_instance_get_beam_int_ptr @ %def sf_chain_instance_get_beam_ptr @ <>= procedure :: get_n_sub => sf_chain_instance_get_n_sub <>= integer function sf_chain_instance_get_n_sub (chain) result (n_sub) type(interaction_t), pointer :: int class(sf_chain_instance_t), intent(in), target :: chain int => beam_get_int_ptr (chain%beam_t) n_sub = int%get_n_sub () end function sf_chain_instance_get_n_sub @ %def sf_chain_instance_get_n_sub @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_base_ut.f90]]>>= <> module sf_base_ut use unit_tests use sf_base_uti <> <> <> contains <> end module sf_base_ut @ %def sf_base_ut @ <<[[sf_base_uti.f90]]>>= <> module sf_base_uti <> <> use io_units use format_defs, only: FMT_19 use format_utils, only: write_separator use diagnostics use lorentz use pdg_arrays use flavors use colors use helicities use quantum_numbers use state_matrices, only: FM_IGNORE_HELICITY use interactions use particles use model_data use beams use sf_aux use sf_mappings use sf_base <> <> <> <> contains <> <> end module sf_base_uti @ %def sf_base_ut @ API: driver for the unit tests below. <>= public :: sf_base_test <>= subroutine sf_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_base_test @ %def sf_base_test @ \subsection{Test implementation: structure function} This is a template for the actual structure-function implementation which will be defined in separate modules. \subsubsection{Configuration data} The test structure function uses the [[Test]] model. It describes a scalar within an arbitrary initial particle, which is given in the initialization. The radiated particle is also a scalar, the same one, but we set its mass artificially to zero. <>= public :: sf_test_data_t <>= type, extends (sf_data_t) :: sf_test_data_t class(model_data_t), pointer :: model => null () integer :: mode = 0 type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad real(default) :: m = 0 logical :: collinear = .true. real(default), dimension(:), allocatable :: qbounds contains <> end type sf_test_data_t @ %def sf_test_data_t @ Output. <>= procedure :: write => sf_test_data_write <>= subroutine sf_test_data_write (data, unit, verbose) class(sf_test_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A)", advance="no") "radiated = " call data%flv_rad%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m write (u, "(3x,A,L1)") "collinear = ", data%collinear if (.not. data%collinear .and. allocated (data%qbounds)) then write (u, "(3x,A," // FMT_19 // ")") "qmin = ", data%qbounds(1) write (u, "(3x,A," // FMT_19 // ")") "qmax = ", data%qbounds(2) end if end subroutine sf_test_data_write @ %def sf_test_data_write @ Initialization. <>= procedure :: init => sf_test_data_init <>= subroutine sf_test_data_init (data, model, pdg_in, collinear, qbounds, mode) class(sf_test_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in logical, intent(in), optional :: collinear real(default), dimension(2), intent(in), optional :: qbounds integer, intent(in), optional :: mode data%model => model if (present (mode)) data%mode = mode if (pdg_array_get (pdg_in, 1) /= 25) then call msg_fatal ("Test spectrum function: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () if (present (collinear)) data%collinear = collinear call data%flv_out%init (25, model) call data%flv_rad%init (25, model) if (present (qbounds)) then allocate (data%qbounds (2)) data%qbounds = qbounds end if end subroutine sf_test_data_init @ %def sf_test_data_init @ Return the number of parameters: 1 if only consider collinear splitting, 3 otherwise. <>= procedure :: get_n_par => sf_test_data_get_n_par <>= function sf_test_data_get_n_par (data) result (n) class(sf_test_data_t), intent(in) :: data integer :: n if (data%collinear) then n = 1 else n = 3 end if end function sf_test_data_get_n_par @ %def sf_test_data_get_n_par @ Return the outgoing particle PDG code: 25 <>= procedure :: get_pdg_out => sf_test_data_get_pdg_out <>= subroutine sf_test_data_get_pdg_out (data, pdg_out) class(sf_test_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 end subroutine sf_test_data_get_pdg_out @ %def sf_test_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => sf_test_data_allocate_sf_int <>= subroutine sf_test_data_allocate_sf_int (data, sf_int) class(sf_test_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int if (allocated (sf_int)) deallocate (sf_int) allocate (sf_test_t :: sf_int) end subroutine sf_test_data_allocate_sf_int @ %def sf_test_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_t type(sf_test_data_t), pointer :: data => null () real(default) :: x = 0 contains <> end type sf_test_t @ %def sf_test_t @ Type string: constant <>= procedure :: type_string => sf_test_type_string <>= function sf_test_type_string (object) result (string) class(sf_test_t), intent(in) :: object type(string_t) :: string string = "Test" end function sf_test_type_string @ %def sf_test_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_write <>= subroutine sf_test_write (object, unit, testflag) class(sf_test_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test data: [undefined]" end if end subroutine sf_test_write @ %def sf_test_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => sf_test_init <>= subroutine sf_test_init (sf_int, data) class(sf_test_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_data_t) if (allocated (data%qbounds)) then call sf_int%base_init (mask, & [data%m**2], [0._default], [data%m**2], & [data%qbounds(1)], [data%qbounds(2)]) else call sf_int%base_init (mask, & [data%m**2], [0._default], [data%m**2]) end if sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_rad, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn) call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select sf_int%status = SF_INITIAL end subroutine sf_test_init @ %def sf_test_init @ Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => sf_test_complete_kinematics <>= subroutine sf_test_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then x(1) = r(1)**2 f = 2 * r(1) else x(1) = r(1) f = 1 end if xb(1) = 1 - x(1) if (size (x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) sf_int%x = x(1) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine sf_test_complete_kinematics @ %def sf_test_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_inverse_kinematics <>= subroutine sf_test_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then r(1) = sqrt (x(1)) f = 2 * r(1) else r(1) = x(1) f = 1 end if if (size (x) == 3) r(2:3) = x(2:3) rb = 1 - r sf_int%x = x(1) if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine sf_test_inverse_kinematics @ %def sf_test_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. If the [[mode]] indicator is one, the matrix element is equal to the parameter~$x$. <>= procedure :: apply => sf_test_apply <>= subroutine sf_test_apply (sf_int, scale, negative_sf, rescale, i_sub) class(sf_test_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub select case (sf_int%data%mode) case (0) call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) case (1) call sf_int%set_matrix_element & (cmplx (sf_int%x, kind=default)) end select sf_int%status = SF_EVALUATED end subroutine sf_test_apply @ %def sf_test_apply @ \subsection{Test implementation: pair spectrum} Another template, this time for a incoming particle pair, splitting into two radiated and two outgoing particles. \subsubsection{Configuration data} For simplicity, the spectrum contains two mirror images of the previous structure-function configuration: the incoming and all outgoing particles are test scalars. We have two versions, one with radiated particles, one without. <>= type, extends (sf_data_t) :: sf_test_spectrum_data_t class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad logical :: with_radiation = .true. real(default) :: m = 0 contains <> end type sf_test_spectrum_data_t @ %def sf_test_spectrum_data_t @ Output. <>= procedure :: write => sf_test_spectrum_data_write <>= subroutine sf_test_spectrum_data_write (data, unit, verbose) class(sf_test_spectrum_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test spectrum data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A)", advance="no") "radiated = " call data%flv_rad%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m end subroutine sf_test_spectrum_data_write @ %def sf_test_spectrum_data_write @ Initialization. <>= procedure :: init => sf_test_spectrum_data_init <>= subroutine sf_test_spectrum_data_init (data, model, pdg_in, with_radiation) class(sf_test_spectrum_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in logical, intent(in) :: with_radiation data%model => model data%with_radiation = with_radiation if (pdg_array_get (pdg_in, 1) /= 25) then call msg_fatal ("Test structure function: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () call data%flv_out%init (25, model) if (with_radiation) then call data%flv_rad%init (25, model) end if end subroutine sf_test_spectrum_data_init @ %def sf_test_spectrum_data_init @ Return the number of parameters: 2, since we have only collinear splitting here. <>= procedure :: get_n_par => sf_test_spectrum_data_get_n_par <>= function sf_test_spectrum_data_get_n_par (data) result (n) class(sf_test_spectrum_data_t), intent(in) :: data integer :: n n = 2 end function sf_test_spectrum_data_get_n_par @ %def sf_test_spectrum_data_get_n_par @ Return the outgoing particle PDG codes: 25 <>= procedure :: get_pdg_out => sf_test_spectrum_data_get_pdg_out <>= subroutine sf_test_spectrum_data_get_pdg_out (data, pdg_out) class(sf_test_spectrum_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 pdg_out(2) = 25 end subroutine sf_test_spectrum_data_get_pdg_out @ %def sf_test_spectrum_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => & sf_test_spectrum_data_allocate_sf_int <>= subroutine sf_test_spectrum_data_allocate_sf_int (data, sf_int) class(sf_test_spectrum_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (sf_test_spectrum_t :: sf_int) end subroutine sf_test_spectrum_data_allocate_sf_int @ %def sf_test_spectrum_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_spectrum_t type(sf_test_spectrum_data_t), pointer :: data => null () contains <> end type sf_test_spectrum_t @ %def sf_test_spectrum_t <>= procedure :: type_string => sf_test_spectrum_type_string <>= function sf_test_spectrum_type_string (object) result (string) class(sf_test_spectrum_t), intent(in) :: object type(string_t) :: string string = "Test Spectrum" end function sf_test_spectrum_type_string @ %def sf_test_spectrum_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_spectrum_write <>= subroutine sf_test_spectrum_write (object, unit, testflag) class(sf_test_spectrum_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test spectrum data: [undefined]" end if end subroutine sf_test_spectrum_write @ %def sf_test_spectrum_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_spectrum_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => sf_test_spectrum_init <>= subroutine sf_test_spectrum_init (sf_int, data) class(sf_test_spectrum_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(6) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(6) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_spectrum_data_t) if (data%with_radiation) then call sf_int%base_init (mask(1:6), & [data%m**2, data%m**2], & [0._default, 0._default], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_rad, col0, hel0) call qn(4)%init (data%flv_rad, col0, hel0) call qn(5)%init (data%flv_out, col0, hel0) call qn(6)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:6)) call sf_int%set_incoming ([1,2]) call sf_int%set_radiated ([3,4]) call sf_int%set_outgoing ([5,6]) else call sf_int%base_init (mask(1:4), & [data%m**2, data%m**2], & [real(default) :: ], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call qn(4)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:4)) call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) end if call sf_int%freeze () end select sf_int%status = SF_INITIAL end subroutine sf_test_spectrum_init @ %def sf_test_spectrum_init @ Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ (as above) for both $x$ parameters and consequently $f(r)=4r_1r_2$. <>= procedure :: complete_kinematics => sf_test_spectrum_complete_kinematics <>= subroutine sf_test_spectrum_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default), dimension(2) :: xb1 if (map) then x = r**2 f = 4 * r(1) * r(2) else x = r f = 1 end if xb = 1 - x if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine sf_test_spectrum_complete_kinematics @ %def sf_test_spectrum_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_spectrum_inverse_kinematics <>= subroutine sf_test_spectrum_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default), dimension(2) :: xb1 logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then r = sqrt (x) f = 4 * r(1) * r(2) else r = x f = 1 end if rb = 1 - r if (set_mom) then if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine sf_test_spectrum_inverse_kinematics @ %def sf_test_spectrum_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. <>= procedure :: apply => sf_test_spectrum_apply <>= subroutine sf_test_spectrum_apply (sf_int, scale, negative_sf, rescale, i_sub) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) sf_int%status = SF_EVALUATED end subroutine sf_test_spectrum_apply @ %def sf_test_spectrum_apply @ \subsection{Test implementation: generator spectrum} A generator for two beams, no radiation (for simplicity). \subsubsection{Configuration data} For simplicity, the spectrum contains two mirror images of the previous structure-function configuration: the incoming and all outgoing particles are test scalars. We have two versions, one with radiated particles, one without. <>= type, extends (sf_data_t) :: sf_test_generator_data_t class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad real(default) :: m = 0 contains <> end type sf_test_generator_data_t @ %def sf_test_generator_data_t @ Output. <>= procedure :: write => sf_test_generator_data_write <>= subroutine sf_test_generator_data_write (data, unit, verbose) class(sf_test_generator_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test generator data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m end subroutine sf_test_generator_data_write @ %def sf_test_generator_data_write @ Initialization. <>= procedure :: init => sf_test_generator_data_init <>= subroutine sf_test_generator_data_init (data, model, pdg_in) class(sf_test_generator_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in data%model => model if (pdg_array_get (pdg_in, 1) /= 25) then call msg_fatal ("Test generator: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () call data%flv_out%init (25, model) end subroutine sf_test_generator_data_init @ %def sf_test_generator_data_init @ This structure function is a generator. <>= procedure :: is_generator => sf_test_generator_data_is_generator <>= function sf_test_generator_data_is_generator (data) result (flag) class(sf_test_generator_data_t), intent(in) :: data logical :: flag flag = .true. end function sf_test_generator_data_is_generator @ %def sf_test_generator_data_is_generator @ Return the number of parameters: 2, since we have only collinear splitting here. <>= procedure :: get_n_par => sf_test_generator_data_get_n_par <>= function sf_test_generator_data_get_n_par (data) result (n) class(sf_test_generator_data_t), intent(in) :: data integer :: n n = 2 end function sf_test_generator_data_get_n_par @ %def sf_test_generator_data_get_n_par @ Return the outgoing particle PDG codes: 25 <>= procedure :: get_pdg_out => sf_test_generator_data_get_pdg_out <>= subroutine sf_test_generator_data_get_pdg_out (data, pdg_out) class(sf_test_generator_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 pdg_out(2) = 25 end subroutine sf_test_generator_data_get_pdg_out @ %def sf_test_generator_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => & sf_test_generator_data_allocate_sf_int <>= subroutine sf_test_generator_data_allocate_sf_int (data, sf_int) class(sf_test_generator_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (sf_test_generator_t :: sf_int) end subroutine sf_test_generator_data_allocate_sf_int @ %def sf_test_generator_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_generator_t type(sf_test_generator_data_t), pointer :: data => null () contains <> end type sf_test_generator_t @ %def sf_test_generator_t <>= procedure :: type_string => sf_test_generator_type_string <>= function sf_test_generator_type_string (object) result (string) class(sf_test_generator_t), intent(in) :: object type(string_t) :: string string = "Test Generator" end function sf_test_generator_type_string @ %def sf_test_generator_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_generator_write <>= subroutine sf_test_generator_write (object, unit, testflag) class(sf_test_generator_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test generator data: [undefined]" end if end subroutine sf_test_generator_write @ %def sf_test_generator_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_generator_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass. No radiation. <>= procedure :: init => sf_test_generator_init <>= subroutine sf_test_generator_init (sf_int, data) class(sf_test_generator_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(4) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(4) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_generator_data_t) call sf_int%base_init (mask(1:4), & [data%m**2, data%m**2], & [real(default) :: ], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call qn(4)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:4)) call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%freeze () end select sf_int%status = SF_INITIAL end subroutine sf_test_generator_init @ %def sf_test_generator_init @ This structure function is a generator. <>= procedure :: is_generator => sf_test_generator_is_generator <>= function sf_test_generator_is_generator (sf_int) result (flag) class(sf_test_generator_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function sf_test_generator_is_generator @ %def sf_test_generator_is_generator @ Generate free parameters. This mock generator always produces the nubmers 0.8 and 0.5. <>= procedure :: generate_free => sf_test_generator_generate_free <>= subroutine sf_test_generator_generate_free (sf_int, r, rb, x_free) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free r = [0.8, 0.5] rb= 1 - r x_free = x_free * product (r) end subroutine sf_test_generator_generate_free @ %def sf_test_generator_generate_free @ Recover momentum fractions. Since the x values are free, we also set the [[x_free]] parameter. <>= procedure :: recover_x => sf_test_generator_recover_x <>= subroutine sf_test_generator_recover_x (sf_int, x, xb, x_free) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb) if (present (x_free)) x_free = x_free * product (x) end subroutine sf_test_generator_recover_x @ %def sf_test_generator_recover_x @ Set kinematics. Since this is a generator, just transfer input to output. <>= procedure :: complete_kinematics => sf_test_generator_complete_kinematics <>= subroutine sf_test_generator_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb= rb f = 1 call sf_int%reduce_momenta (x) end subroutine sf_test_generator_complete_kinematics @ %def sf_test_generator_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_generator_inverse_kinematics <>= subroutine sf_test_generator_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta r = x rb= xb f = 1 if (set_mom) call sf_int%reduce_momenta (x) end subroutine sf_test_generator_inverse_kinematics @ %def sf_test_generator_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. <>= procedure :: apply => sf_test_generator_apply <>= subroutine sf_test_generator_apply (sf_int, scale, negative_sf, rescale, i_sub) class(sf_test_generator_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) sf_int%status = SF_EVALUATED end subroutine sf_test_generator_apply @ %def sf_test_generator_apply @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_base_1, "sf_base_1", & "structure function configuration", & u, results) <>= public :: sf_base_1 <>= subroutine sf_base_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_base_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") call model%init_test () pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle code:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_1" end subroutine sf_base_1 @ %def sf_base_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the test structure function. <>= call test (sf_base_2, "sf_base_2", & "structure function instance", & u, results) <>= public :: sf_base_2 <>= subroutine sf_base_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics for x=1" write (u, "(A)") r = 1 rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics with mapping for r=0.8" write (u, "(A)") r = 0.8_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.64 and evaluate" write (u, "(A)") x = 0.64_default call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_2" end subroutine sf_base_2 @ %def sf_base_2 @ \subsubsection{Collinear kinematics} Scan over the possibilities for mass assignment and on-shell projections, collinear case. <>= call test (sf_base_3, "sf_base_3", & "alternatives for collinear kinematics", & u, results) <>= public :: sf_base_3 <>= subroutine sf_base_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_3" write (u, "(A)") "* Purpose: check various kinematical setups" write (u, "(A)") "* for collinear structure-function splitting." write (u, "(A)") " (two masses equal, one zero)" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set radiated mass to zero" sf_int%mr2 = 0 sf_int%mo2 = sf_int%mi2 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set outgoing mass to zero" sf_int%mr2 = sf_int%mi2 sf_int%mo2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set incoming mass to zero" k = vector4_moving (E, E, 3) call sf_int%seed_kinematics ([k]) sf_int%mr2 = sf_int%mi2 sf_int%mo2 = sf_int%mi2 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set all masses to zero" sf_int%mr2 = 0 sf_int%mo2 = 0 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_3" end subroutine sf_base_3 @ %def sf_base_3 @ \subsubsection{Non-collinear kinematics} Scan over the possibilities for mass assignment and on-shell projections, non-collinear case. <>= call test (sf_base_4, "sf_base_4", & "alternatives for non-collinear kinematics", & u, results) <>= public :: sf_base_4 <>= subroutine sf_base_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_4" write (u, "(A)") "* Purpose: check various kinematical setups" write (u, "(A)") "* for free structure-function splitting." write (u, "(A)") " (two masses equal, one zero)" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in, collinear=.false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set radiated mass to zero" sf_int%mr2 = 0 sf_int%mo2 = sf_int%mi2 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set outgoing mass to zero" sf_int%mr2 = sf_int%mi2 sf_int%mo2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set incoming mass to zero" k = vector4_moving (E, E, 3) call sf_int%seed_kinematics ([k]) sf_int%mr2 = sf_int%mi2 sf_int%mo2 = sf_int%mi2 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set all masses to zero" sf_int%mr2 = 0 sf_int%mo2 = 0 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Re-Initialize structure-function object with Q bounds" call reset_interaction_counter () select type (data) type is (sf_test_data_t) call data%init (model, pdg_in, collinear=.false., & qbounds = [1._default, 100._default]) end select call sf_int%init (data) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_4" end subroutine sf_base_4 @ %def sf_base_4 @ \subsubsection{Pair spectrum} Construct and display a structure function object for a pair spectrum (a structure function involving two particles simultaneously). <>= call test (sf_base_5, "sf_base_5", & "pair spectrum with radiation", & u, results) <>= public :: sf_base_5 <>= subroutine sf_base_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(4) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_5" write (u, "(A)") "* Purpose: initialize and fill & &a pair spectrum object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.true.) end select write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 write (u, "(A)") write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.4,0.8" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.4_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics with mapping for r=0.6,0.8" write (u, "(A)") r = [0.6_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.36,0.64 & &and evaluate" write (u, "(A)") x = [0.36_default, 0.64_default] xb = 1 - x call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_5" end subroutine sf_base_5 @ %def sf_base_5 @ \subsubsection{Pair spectrum without radiation} Construct and display a structure function object for a pair spectrum (a structure function involving two particles simultaneously). <>= call test (sf_base_6, "sf_base_6", & "pair spectrum without radiation", & u, results) <>= public :: sf_base_6 <>= subroutine sf_base_6 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_6" write (u, "(A)") "* Purpose: initialize and fill & &a pair spectrum object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.false.) end select write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.4,0.8" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.4_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.4,0.8 & &and evaluate" write (u, "(A)") x = [0.4_default, 0.8_default] xb = 1 - x call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_6" end subroutine sf_base_6 @ %def sf_base_6 @ \subsubsection{Direct access to structure function} Probe a structure function directly. <>= call test (sf_base_7, "sf_base_7", & "direct access", & u, results) <>= public :: sf_base_7 <>= subroutine sf_base_7 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int real(default), dimension(:), allocatable :: value write (u, "(A)") "* Test output: sf_base_7" write (u, "(A)") "* Purpose: check direct access method" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Probe structure function: states" write (u, "(A)") write (u, "(A,I0)") "n_states = ", sf_int%get_n_states () write (u, "(A,I0)") "n_in = ", sf_int%get_n_in () write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad () write (u, "(A,I0)") "n_out = ", sf_int%get_n_out () write (u, "(A)") write (u, "(A)", advance="no") "state(1) = " call quantum_numbers_write (sf_int%get_state (1), u) write (u, *) allocate (value (sf_int%get_n_states ())) call sf_int%compute_values (value, & E=[500._default], x=[0.5_default], xb=[0.5_default], scale=0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500, x=0.5) =" write (u, "(9(1x," // FMT_19 // "))") value call sf_int%compute_values (value, & x=[0.1_default], xb=[0.9_default], scale=0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500, x=0.1) =" write (u, "(9(1x," // FMT_19 // "))") value write (u, "(A)") write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") deallocate (value) call sf_int%final () deallocate (sf_int) deallocate (data) allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.false.) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Probe spectrum: states" write (u, "(A)") write (u, "(A,I0)") "n_states = ", sf_int%get_n_states () write (u, "(A,I0)") "n_in = ", sf_int%get_n_in () write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad () write (u, "(A,I0)") "n_out = ", sf_int%get_n_out () write (u, "(A)") write (u, "(A)", advance="no") "state(1) = " call quantum_numbers_write (sf_int%get_state (1), u) write (u, *) allocate (value (sf_int%get_n_states ())) call sf_int%compute_value (1, value(1), & E = [500._default, 500._default], & x = [0.5_default, 0.6_default], & xb= [0.5_default, 0.4_default], & scale = 0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500,500, x=0.5,0.6) =" write (u, "(9(1x," // FMT_19 // "))") value write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_7" end subroutine sf_base_7 @ %def sf_base_7 @ \subsubsection{Structure function chain configuration} <>= call test (sf_base_8, "sf_base_8", & "structure function chain configuration", & u, results) <>= public :: sf_base_8 <>= subroutine sf_base_8 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_chain_t) :: sf_chain write (u, "(A)") "* Test output: sf_base_8" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_8" end subroutine sf_base_8 @ %def sf_base_8 @ \subsubsection{Structure function instance configuration} We create a structure-function chain instance which implements a configured structure-function chain. We link the momentum entries in the interactions and compute kinematics. We do not actually connect the interactions and create evaluators. We skip this step and manually advance the status of the chain instead. <>= call test (sf_base_9, "sf_base_9", & "structure function chain instance", & u, results) <>= public :: sf_base_9 <>= subroutine sf_base_9 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel type(vector4_t), dimension(2) :: p integer :: j write (u, "(A)") "* Test output: sf_base_9" write (u, "(A)") "* Purpose: set up a structure-function chain & &and create an instance" write (u, "(A)") "* compute kinematics" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [real(default) ::]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [0.8_default]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics & (1, [0.5_default, 0.6_default, 0.8_default]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_9" end subroutine sf_base_9 @ %def sf_base_9 @ \subsubsection{Structure function chain mappings} Set up a structure function chain instance with a pair of single-particle structure functions. We test different global mappings for this setup. Again, we skip evaluators. <>= call test (sf_base_10, "sf_base_10", & "structure function chain mapping", & u, results) <>= public :: sf_base_10 <>= subroutine sf_base_10 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel real(default), dimension(2) :: x_saved write (u, "(A)") "* Test output: sf_base_10" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* and check mappings" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with structure function pair & &and standard mapping" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1], data_strfun) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (2) call sf_channel(1)%set_s_mapping ([1,2]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default]) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Invert the kinematics calculation" write (u, "(A)") x_saved = sf_chain_instance%x call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%set_s_mapping ([1, 2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_10" end subroutine sf_base_10 @ %def sf_base_10 @ \subsubsection{Structure function chain evaluation} Here, we test the complete workflow for structure-function chains. First, we create the template chain, then initialize an instance. We set up links, mask, and evaluators. Finally, we set kinematics and evaluate the matrix elements and their products. <>= call test (sf_base_11, "sf_base_11", & "structure function chain evaluation", & u, results) <>= public :: sf_base_11 <>= subroutine sf_base_11 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel type(particle_set_t) :: pset type(interaction_t), pointer :: int logical :: ok write (u, "(A)") "* Test output: sf_base_11" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* create an instance and evaluate" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics (1, [real(default) ::]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics (1, [0.8_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics & (1, [0.5_default, 0.6_default, 0.8_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_11" end subroutine sf_base_11 @ %def sf_base_11 @ \subsubsection{Multichannel case} We set up a structure-function chain as before, but with three different parameterizations. The first instance is without mappings, the second one with single-particle mappings, and the third one with two-particle mappings. <>= call test (sf_base_12, "sf_base_12", & "multi-channel structure function chain", & u, results) <>= public :: sf_base_12 <>= subroutine sf_base_12 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance real(default), dimension(2) :: x_saved real(default), dimension(2,3) :: p_saved type(sf_channel_t), dimension(:), allocatable :: sf_channel write (u, "(A)") "* Test output: sf_base_12" write (u, "(A)") "* Purpose: set up and evaluate a multi-channel & &structure-function chain" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with structure function pair & &and three different mappings" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 3) call allocate_sf_channels (sf_channel, n_channel = 3, n_strfun = 2) ! channel 1: no mapping call sf_chain_instance%set_channel (1, sf_channel(1)) ! channel 2: single-particle mappings call sf_channel(2)%activate_mapping ([1,2]) ! call sf_chain_instance%activate_mapping (2, [1,2]) call sf_chain_instance%set_channel (2, sf_channel(2)) ! channel 3: two-particle mapping call sf_channel(3)%set_s_mapping ([1,2]) ! call sf_chain_instance%set_s_mapping (3, [1, 2]) call sf_chain_instance%set_channel (3, sf_channel(3)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () write (u, "(A)") "* Compute kinematics in channel 1 and evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Invert the kinematics calculation" write (u, "(A)") x_saved = sf_chain_instance%x call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Compute kinematics in channel 2 and evaluate" write (u, "(A)") p_saved = sf_chain_instance%p call sf_chain_instance%compute_kinematics (2, p_saved(:,2)) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Compute kinematics in channel 3 and evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (3, p_saved(:,3)) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_chain_instance%final () call sf_chain%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_12" end subroutine sf_base_12 @ %def sf_base_12 @ \subsubsection{Generated spectrum} Construct and evaluate a structure function object for a pair spectrum which is evaluated as a beam-event generator. <>= call test (sf_base_13, "sf_base_13", & "pair spectrum generator", & u, results) <>= public :: sf_base_13 <>= subroutine sf_base_13 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_base_13" write (u, "(A)") "* Purpose: initialize and fill & &a pair generator object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_generator_data_t :: data) select type (data) type is (sf_test_generator_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize generator object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") "* Generate free r values" write (u, "(A)") x_free = 1 call sf_int%generate_free (r, rb, x_free) write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Complete kinematics" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) x_free = 1 call sf_int%recover_x (x, xb, x_free) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics & &and evaluate" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_13" end subroutine sf_base_13 @ %def sf_base_13 @ \subsubsection{Structure function chain evaluation} Here, we test the complete workflow for a structure-function chain with generator. First, we create the template chain, then initialize an instance. We set up links, mask, and evaluators. Finally, we set kinematics and evaluate the matrix elements and their products. <>= call test (sf_base_14, "sf_base_14", & "structure function generator evaluation", & u, results) <>= public :: sf_base_14 <>= subroutine sf_base_14 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_generator type(sf_config_t), dimension(:), allocatable, target :: sf_config real(default), dimension(:), allocatable :: p_in type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance write (u, "(A)") "* Test output: sf_base_14" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* create an instance and evaluate" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_generator_data_t :: data_generator) select type (data_generator) type is (sf_test_generator_data_t) call data_generator%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with generator and structure function" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_generator) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () write (u, "(A)") "* Inject integration parameter" write (u, "(A)") allocate (p_in (sf_chain%get_n_bound ()), source = 0.9_default) write (u, "(A,9(1x,F10.7))") "p_in =", p_in write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (1, p_in) call sf_chain_instance%evaluate (scale=0._default) call sf_chain_instance%write (u) write (u, "(A)") write (u, "(A)") "* Extract integration parameter" write (u, "(A)") call sf_chain_instance%get_mcpar (1, p_in) write (u, "(A,9(1x,F10.7))") "p_in =", p_in call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_14" end subroutine sf_base_14 @ %def sf_base_14 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Photon radiation: ISR} <<[[sf_isr.f90]]>>= <> module sf_isr <> <> use io_units use constants, only: pi use format_defs, only: FMT_15, FMT_19 use numeric_utils use diagnostics use physics_defs, only: PHOTON use lorentz use sm_physics, only: Li2 use pdg_arrays use model_data use flavors use colors use quantum_numbers use polarizations use sf_aux use sf_mappings use sf_base use electron_pdfs <> <> <> <> contains <> end module sf_isr @ %def sf_isr @ \subsection{Physics} The ISR structure function is in the most crude approximation (LLA without $\alpha$ corrections, i.e. $\epsilon^0$) \begin{equation} f_0(x) = \epsilon (1-x)^{-1+\epsilon} \qquad\text{with}\qquad \epsilon = \frac{\alpha}{\pi}q_e^2\ln\frac{s}{m^2}, \end{equation} where $m$ is the mass of the incoming (and outgoing) particle, which is initially assumed on-shell. In $f_0(x)$, there is an integrable singularity at $x=1$ which does not spoil the integration, but would lead to an unbounded $f_{\rm max}$. Therefore, we map this singularity like \begin{equation}\label{ISR-mapping} x = 1 - (1-x')^{1/\epsilon} \end{equation} such that \begin{equation} \int dx\,f_0(x) = \int dx' \end{equation} For the detailed form of the QED ISR structure function cf. Chap.~\ref{chap:qed_pdf}. \subsection{Implementation} In the concrete implementation, the zeroth order mapping (\ref{ISR-mapping}) is implemented, and the Jacobian is equal to $f_i(x)/f_0(x)$. This can be written as \begin{align} \frac{f_0(x)}{f_0(x)} &= 1 \\ \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon - \frac{1-x^2}{2(1-x')} \\ \begin{split}\label{ISR-f2} \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 - \frac{1-x^2}{2(1-x')} \\ &\quad - \frac{(1+3x^2)\ln x + (1-x)\left(4(1+x)\ln(1-x) + 5 + x\right)}{8(1-x')}\epsilon \end{split} \end{align} %' For $x=1$ (i.e., numerically indistinguishable from $1$), this reduces to \begin{align} \frac{f_0(x)}{f_0(x)} &= 1 \\ \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon \\ \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 \end{align} The last line in (\ref{ISR-f2}) is zero for \begin{equation} x_{\rm min} = 0.00714053329734592839549879772019 \end{equation} (Mathematica result), independent of $\epsilon$. For $x$ values less than this we ignore this correction because of the logarithmic singularity which should in principle be resummed. \subsection{The ISR data block} <>= public :: isr_data_t <>= type, extends (sf_data_t) :: isr_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in type(qed_pdf_t) :: pdf real(default) :: alpha = 0 real(default) :: q_max = 0 real(default) :: real_mass = 0 real(default) :: mass = 0 real(default) :: eps = 0 real(default) :: log = 0 logical :: recoil = .false. logical :: keep_energy = .true. integer :: order = 3 integer :: error = NONE contains <> end type isr_data_t @ %def isr_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_MASS = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: EPS_TOO_LARGE = 3 integer, parameter :: INVALID_ORDER = 4 integer, parameter :: CHARGE_MIX = 5 integer, parameter :: CHARGE_ZERO = 6 integer, parameter :: MASS_MIX = 7 @ Generate flavor-dependent ISR data: <>= procedure :: init => isr_data_init <>= subroutine isr_data_init (data, model, pdg_in, alpha, q_max, & mass, order, recoil, keep_energy) class(isr_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: alpha real(default), intent(in) :: q_max real(default), intent(in), optional :: mass integer, intent(in), optional :: order logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy integer :: i, n_flv real(default) :: charge data%model => model n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model) end do data%alpha = alpha data%q_max = q_max if (present (order)) then call data%set_order (order) end if if (present (recoil)) then data%recoil = recoil end if if (present (keep_energy)) then data%keep_energy = keep_energy end if data%real_mass = data%flv_in(1)%get_mass () if (present (mass)) then if (mass > 0) then data%mass = mass else data%mass = data%real_mass if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if else data%mass = data%real_mass if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if if (vanishes (data%mass)) then data%error = ZERO_MASS; return else if (data%mass >= data%q_max) then data%error = Q_MAX_TOO_SMALL; return end if data%log = log (1 + (data%q_max / data%mass)**2) charge = data%flv_in(1)%get_charge () if (any (abs (data%flv_in%get_charge ()) /= abs (charge))) then data%error = CHARGE_MIX; return else if (charge == 0) then data%error = CHARGE_ZERO; return end if data%eps = data%alpha / pi * charge ** 2 & * (2 * log (data%q_max / data%mass) - 1) if (data%eps > 1) then data%error = EPS_TOO_LARGE; return end if call data%pdf%init & (data%mass, data%alpha, charge, data%q_max, data%order) end subroutine isr_data_init @ %def isr_data_init @ Explicitly set ISR order <>= procedure :: set_order => isr_data_set_order <>= elemental subroutine isr_data_set_order (data, order) class(isr_data_t), intent(inout) :: data integer, intent(in) :: order if (order < 0 .or. order > 3) then data%error = INVALID_ORDER else data%order = order end if end subroutine isr_data_set_order @ %def isr_data_set_order @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => isr_data_check <>= subroutine isr_data_check (data) class(isr_data_t), intent(in) :: data select case (data%error) case (ZERO_MASS) call msg_fatal ("ISR: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("ISR: Particle mass exceeds Qmax") case (EPS_TOO_LARGE) call msg_fatal ("ISR: Expansion parameter too large, " // & "perturbative expansion breaks down") case (INVALID_ORDER) call msg_error ("ISR: LLA order invalid (valid values are 0,1,2,3)") case (MASS_MIX) call msg_fatal ("ISR: Incoming particle masses must be uniform") case (CHARGE_MIX) call msg_fatal ("ISR: Incoming particle charges must be uniform") case (CHARGE_ZERO) call msg_fatal ("ISR: Incoming particle must be charged") end select end subroutine isr_data_check @ %def isr_data_check @ Output <>= procedure :: write => isr_data_write <>= subroutine isr_data_write (data, unit, verbose) class(isr_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "ISR data:" if (allocated (data%flv_in)) then write (u, "(3x,A)", advance="no") " flavor = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " eps = ", data%eps write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log write (u, "(3x,A,I2)") " order = ", data%order write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy else write (u, "(3x,A)") "[undefined]" end if end subroutine isr_data_write @ %def isr_data_write @ For ISR, there is the option to generate transverse momentum is generated. Hence, there can be up to three parameters, $x$, and two angles. <>= procedure :: get_n_par => isr_data_get_n_par <>= function isr_data_get_n_par (data) result (n) class(isr_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function isr_data_get_n_par @ %def isr_data_get_n_par @ Return the outgoing particles PDG codes. For ISR, these are identical to the incoming particles. <>= procedure :: get_pdg_out => isr_data_get_pdg_out <>= subroutine isr_data_get_pdg_out (data, pdg_out) class(isr_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = data%flv_in%get_pdg () end subroutine isr_data_get_pdg_out @ %def isr_data_get_pdg_out @ Return the [[eps]] value. We need it for an appropriate mapping of structure-function parameters. <>= procedure :: get_eps => isr_data_get_eps <>= function isr_data_get_eps (data) result (eps) class(isr_data_t), intent(in) :: data real(default) :: eps eps = data%eps end function isr_data_get_eps @ %def isr_data_get_eps @ Allocate the interaction record. <>= procedure :: allocate_sf_int => isr_data_allocate_sf_int <>= subroutine isr_data_allocate_sf_int (data, sf_int) class(isr_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (isr_t :: sf_int) end subroutine isr_data_allocate_sf_int @ %def isr_data_allocate_sf_int @ \subsection{The ISR object} The [[isr_t]] data type is a $1\to 2$ interaction, i.e., we allow for single-photon emission only (but use the multi-photon resummed radiator function). The particles are ordered as (incoming, photon, outgoing). There is no need to handle several flavors (and data blocks) in parallel, since ISR is always applied immediately after beam collision. (ISR for partons is accounted for by the PDFs themselves.) Polarization is carried through, i.e., we retain the polarization of the incoming particle and treat the emitted photon as unpolarized. Color is trivially carried through. This implies that particles 1 and 3 should be locked together. For ISR we don't need the q variable. <>= public :: isr_t <>= type, extends (sf_int_t) :: isr_t private type(isr_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb= 0 contains <> end type isr_t @ %def isr_t @ Type string: has to be here, but there is no string variable on which ISR depends. Hence, a dummy routine. <>= procedure :: type_string => isr_type_string <>= function isr_type_string (object) result (string) class(isr_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "ISR: e+ e- ISR spectrum" else string = "ISR: [undefined]" end if end function isr_type_string @ %def isr_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => isr_write <>= subroutine isr_write (object, unit, testflag) class(isr_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_15 // ")") "x =", object%x write (u, "(3x,A," // FMT_15 // ")") "xb=", object%xb end if call object%base_write (u, testflag) else write (u, "(1x,A)") "ISR data: [undefined]" end if end subroutine isr_write @ %def isr_write @ Explicitly set ISR order (for unit test). <>= procedure :: set_order => isr_set_order <>= subroutine isr_set_order (object, order) class(isr_t), intent(inout) :: object integer, intent(in) :: order call object%data%set_order (order) call object%data%pdf%set_order (order) end subroutine isr_set_order @ %def isr_set_order @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ were trivial. The ISR structure function allows for a straightforward mapping of the unit interval. So, to leading order, the structure function value is unity, but the $x$ value is transformed. Higher orders affect the function value. The structure function implementation applies the above mapping to the input (random) number [[r]] to generate the momentum fraction [[x]] and the function value [[f]]. For numerical stability reasons, we also output [[xb]], which is $\bar x=1-x$. For the ISR structure function, the mapping Jacobian cancels the structure function (to order zero). We apply the cancellation explicitly, therefore both the Jacobian [[f]] and the zeroth-order value (see the [[apply]] method) are unity if mapping is turned on. If mapping is turned off, the Jacobian [[f]] includes the value of the (zeroth-order) structure function, and strongly peaked. <>= procedure :: complete_kinematics => isr_complete_kinematics <>= subroutine isr_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: eps eps = sf_int%data%eps if (map) then call map_power_1 (sf_int%xb, f, rb(1), eps) else sf_int%xb = rb(1) if (rb(1) > 0) then f = 1 else f = 0 end if end if sf_int%x = 1 - sf_int%xb x(1) = sf_int%x xb(1) = sf_int%xb if (size (x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb= 0 f = 0 end select end subroutine isr_complete_kinematics @ %def isr_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of ISR, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. <>= procedure :: recover_x => sf_isr_recover_x <>= subroutine sf_isr_recover_x (sf_int, x, xb, x_free) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_isr_recover_x @ %def sf_isr_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. For extracting $x$, we rely on the stored $\bar x$ value, since the $x$ value in the argument is likely imprecise. This means that either [[complete_kinematics]] or [[recover_x]] must be called first, for the current sampling point (but maybe another channel). <>= procedure :: inverse_kinematics => isr_inverse_kinematics <>= subroutine isr_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: eps logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta eps = sf_int%data%eps if (map) then call map_power_inverse_1 (xb(1), f, rb(1), eps) else rb(1) = xb(1) if (rb(1) > 0) then f = 1 else f = 0 end if end if r(1) = 1 - rb(1) if (size(r) == 3) then r(2:3) = x(2:3) rb(2:3)= xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS) r = 0 rb= 0 f = 0 end select end if end subroutine isr_inverse_kinematics @ %def isr_inverse_kinematics @ <>= procedure :: init => isr_init <>= subroutine isr_init (sf_int, data) class(isr_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc type(flavor_t) :: flv_photon type(color_t) :: col_photon type(quantum_numbers_t) :: qn_hel, qn_photon, qn type(polarization_iterator_t) :: it_hel real(default) :: m2 integer :: i mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .true., .false.]) hel_lock = [3, 0, 1] select type (data) type is (isr_data_t) m2 = data%mass**2 call sf_int%base_init (mask, [m2], [0._default], [m2], & hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col_photon%init () call qn_photon%init (flv_photon, col_photon) call qn_photon%tag_radiated () do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init (& flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) call sf_int%add_state ([qn, qn_photon, qn]) call it_hel%advance () end do ! call pol%final () !!! Obsolete end do call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine isr_init @ %def isr_init @ \subsection{ISR application} For ISR, we could in principle compute kinematics and function value in a single step. In order to be able to reweight matrix elements including structure functions we split kinematics and structure function calculation. The structure function works on a single beam, assuming that the input momentum has been set. For the structure-function evaluation, we rely on the fact that the power mapping, which we apply in the kinematics method (if the [[map]] flag is set), has a Jacobian which is just the inverse lowest-order structure function. With mapping active, the two should cancel exactly. After splitting momenta, we set the outgoing momenta on-shell. We choose to conserve momentum, so energy conservation may be violated. <>= procedure :: apply => isr_apply <>= subroutine isr_apply (sf_int, scale, negative_sf, rescale, i_sub) class(isr_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f, finv, x, xb, eps, rb real(default) :: log_x, log_xb, x_2 associate (data => sf_int%data) eps = sf_int%data%eps x = sf_int%x xb = sf_int%xb call map_power_inverse_1 (xb, finv, rb, eps) if (finv > 0) then f = 1 / finv else f = 0 end if call data%pdf%evolve_qed_pdf (x, xb, rb, f) end associate call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine isr_apply @ %def isr_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_isr_ut.f90]]>>= <> module sf_isr_ut use unit_tests use sf_isr_uti <> <> contains <> end module sf_isr_ut @ %def sf_isr_ut @ <<[[sf_isr_uti.f90]]>>= <> module sf_isr_uti <> <> use io_units use format_defs, only: FMT_12 use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use interactions, only: interaction_pacify_momenta use model_data use sf_aux, only: KEEP_ENERGY use sf_mappings use sf_base use sf_isr <> <> contains <> end module sf_isr_uti @ %def sf_isr_ut @ API: driver for the unit tests below. <>= public :: sf_isr_test <>= subroutine sf_isr_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_isr_test @ %def sf_isr_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_isr_1, "sf_isr_1", & "structure function configuration", & u, results) <>= public :: sf_isr_1 <>= subroutine sf_isr_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_isr_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON allocate (isr_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 10._default, & 0.000511_default, order = 3, recoil = .false.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_1" end subroutine sf_isr_1 @ %def sf_isr_1 @ \subsubsection{Structure function without mapping} Direct ISR evaluation. This is the use case for a double-beam structure function. The parameter pair is mapped in the calling program. <>= call test (sf_isr_2, "sf_isr_2", & "no ISR mapping", & u, results) <>= public :: sf_isr_2 <>= subroutine sf_isr_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr write (u, "(A)") "* Test output: sf_isr_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON call flv%init (ELECTRON, model) call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.9, no ISR mapping, & &collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.9_default rb = 1 - r write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Re-evaluate structure function, leading order" write (u, "(A)") select type (sf_int) type is (isr_t) call sf_int%set_order (0) end select call sf_int%apply (scale = 100._default) f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_2" end subroutine sf_isr_2 @ %def sf_isr_2 @ \subsubsection{Structure function with mapping} Apply the optimal ISR mapping. This is the use case for a single-beam structure function. <>= call test (sf_isr_3, "sf_isr_3", & "ISR mapping", & u, results) <>= public :: sf_isr_3 <>= subroutine sf_isr_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr write (u, "(A)") "* Test output: sf_isr_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.7, with ISR mapping, & &collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.7_default rb = 1 - r write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Re-evaluate structure function, leading order" write (u, "(A)") select type (sf_int) type is (isr_t) call sf_int%set_order (0) end select call sf_int%apply (scale = 100._default) f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_3" end subroutine sf_isr_3 @ %def sf_isr_3 @ \subsubsection{Non-collinear ISR splitting} Construct and display a structure function object based on the ISR structure function. We blank out numerical fluctuations for 32bit. <>= call test (sf_isr_4, "sf_isr_4", & "ISR non-collinear", & u, results) <>= public :: sf_isr_4 <>= subroutine sf_isr_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr character(len=80) :: buffer integer :: u_scratch, iostat write (u, "(A)") "* Test output: sf_isr_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () write (u, "(A)") write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .true.) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.25, with ISR mapping, " write (u, "(A)") " non-coll., keeping energy" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) call sf_int%apply (scale = 10._default) u_scratch = free_unit () open (u_scratch, status="scratch", action = "readwrite") call sf_int%write (u_scratch, testflag = .true.) rewind (u_scratch) do read (u_scratch, "(A)", iostat=iostat) buffer if (iostat /= 0) exit if (buffer(1:25) == " P = 0.000000E+00 9.57") then buffer = replace (buffer, 26, "XXXX") end if if (buffer(1:25) == " P = 0.000000E+00 -9.57") then buffer = replace (buffer, 26, "XXXX") end if write (u, "(A)") buffer end do close (u_scratch) write (u, "(A)") write (u, "(A)") "* Structure-function value" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_4" end subroutine sf_isr_4 @ %def sf_isr_4 @ \subsubsection{Structure function pair with mapping} Apply the ISR mapping for a ISR pair. structure function. <>= call test (sf_isr_5, "sf_isr_5", & "ISR pair mapping", & u, results) <>= public :: sf_isr_5 <>= subroutine sf_isr_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_mapping_t), allocatable :: mapping class(sf_int_t), dimension(:), allocatable :: sf_int type(vector4_t), dimension(2) :: k real(default) :: E, f_map real(default), dimension(:), allocatable :: p, pb, r, rb, x, xb real(default), dimension(2) :: f, f_isr integer :: i write (u, "(A)") "* Test output: sf_isr_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select allocate (sf_ip_mapping_t :: mapping) select type (mapping) type is (sf_ip_mapping_t) select type (data) type is (isr_data_t) call mapping%init (eps = data%get_eps ()) end select call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, "(A)") write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (isr_t :: sf_int (2)) do i = 1, 2 call sf_int(i)%init (data) call sf_int(i)%set_beam_index ([i]) end do write (u, "(A)") "* Initialize incoming momenta with E=500" write (u, "(A)") E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, - sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) do i = 1, 2 call vector4_write (k(i), u) call sf_int(i)%seed_kinematics (k(i:i)) end do write (u, "(A)") write (u, "(A)") "* Set kinematics for p=[0.7,0.4], collinear" write (u, "(A)") allocate (p (2 * data%get_n_par ())) allocate (pb(size (p))) allocate (r (size (p))) allocate (rb(size (p))) allocate (x (size (p))) allocate (xb(size (p))) p = [0.7_default, 0.4_default] pb= 1 - p call mapping%compute (r, rb, f_map, p, pb) write (u, "(A,9(1x," // FMT_12 // "))") "p =", p write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map do i = 1, 2 call sf_int(i)%complete_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), & map=.false.) end do write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") do i = 1, 2 call sf_int(i)%inverse_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), & map=.false.) end do call mapping%inverse (r, rb, f_map, p, pb) write (u, "(A,9(1x," // FMT_12 // "))") "p =", p write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" call sf_int(1)%apply (scale = 100._default) call sf_int(2)%apply (scale = 100._default) write (u, "(A)") write (u, "(A)") "* Structure function #1" write (u, "(A)") call sf_int(1)%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Structure function #2" write (u, "(A)") call sf_int(2)%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") do i = 1, 2 f_isr(i) = sf_int(i)%get_matrix_element (1) end do write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", & product (f_isr) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", & product (f_isr * f) * f_map write (u, "(A)") write (u, "(A)") "* Cleanup" do i = 1, 2 call sf_int(i)%final () end do call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_5" end subroutine sf_isr_5 @ %def sf_isr_5 @ \clearpage %------------------------------------------------------------------------ \section{EPA} <<[[sf_epa.f90]]>>= <> module sf_epa <> <> use io_units use constants, only: pi use format_defs, only: FMT_17, FMT_19 use numeric_utils use diagnostics use physics_defs, only: PHOTON use lorentz use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use interactions use sf_aux use sf_base <> <> <> <> contains <> end module sf_epa @ %def sf_epa @ \subsection{Physics} The EPA structure function for a photon inside an (elementary) particle $p$ with energy $E$, mass $m$ and charge $q_p$ (e.g., electron) is given by ($\bar x \equiv 1-x$) There are several variants of the EPA, which are steered by the [[\$epa\_mode]] switch. The formula (6.17b) from the report by Budnev et al. is given by %% %\cite{Budnev:1974de} %% \bibitem{Budnev:1974de} %% V.~M.~Budnev, I.~F.~Ginzburg, G.~V.~Meledin and V.~G.~Serbo, %% %``The Two photon particle production mechanism. Physical problems. %% %Applications. Equivalent photon approximation,'' %% Phys.\ Rept.\ {\bf 15} (1974) 181. %% %%CITATION = PRPLC,15,181;%% \begin{multline} \label{EPA_617} f(x) = \frac{\alpha}{\pi}\,q_p^2\, \frac{1}{x}\, \biggl[\left(\bar x + \frac{x^2}{2}\right) \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}} \\ - \left(1 - \frac{x}{2}\right)^2 \ln\frac{x^2+\frac{Q^2_{\rm max}}{E^2}} {x^2+\frac{Q^2_{\rm min}}{E^2}} - x^2\frac{m^2}{Q^2_{\rm min}} \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right) \biggr]. \end{multline} If no explicit $Q$ bounds are provided, the kinematical bounds are \begin{align} -Q^2_{\rm max} &= t_0 = -2\bar x(E^2+p\bar p) + 2m^2 \approx -4\bar x E^2, \\ -Q^2_{\rm min} &= t_1 = -2\bar x(E^2-p\bar p) + 2m^2 \approx -\frac{x^2}{\bar x}m^2. \end{align} The second and third terms in (\ref{EPA_617}) are negative definite (and subleading). Noting that $\bar x + x^2/2$ is bounded between $1/2$ and $1$, we derive that $f(x)$ is always smaller than \begin{equation} \bar f(x) = \frac{\alpha}{\pi}\,q_p^2\,\frac{L - 2\ln x}{x} \qquad\text{where}\qquad L = \ln\frac{\min(4E_{\rm max}^2,Q^2_{\rm max})}{\max(m^2,Q_{\rm min}^2)}, \end{equation} where we allow for explicit $Q$ bounds that narrow the kinematical range. Therefore, we generate this distribution: \begin{equation}\label{EPA-subst} \int_{x_0}^{x_1} dx\,\bar f(x) = C(x_0,x_1)\int_0^1 dx' \end{equation} We set \begin{equation}\label{EPA-x(x')} \ln x = \frac12\left\{ L - \sqrt{L^2 - 4\left[ x'\ln x_1(L-\ln x_1) + \bar x'\ln x_0(L-\ln x_0) \right]} \right\} \end{equation} such that $x(0)=x_0$ and $x(1)=x_1$ and \begin{equation} \frac{dx}{dx'} = \left(\frac{\alpha}{\pi} q_p^2 \right)^{-1} x\frac{C(x_0,x_1)}{L - 2\ln x} \end{equation} with \begin{equation} C(x_0,x_1) = \frac{\alpha}{\pi} q_p^2\,\left[\ln x_1(L-\ln x_1) - \ln x_0(L-\ln x_0)\right] \end{equation} such that (\ref{EPA-subst}) is satisfied. Finally, we have \begin{equation} \int_{x_0}^{x_1} dx\,f(x) = C(x_0,x_1)\int_0^1 dx'\, \frac{f(x(x'))}{\bar f(x(x'))} \end{equation} where $x'$ is calculated from $x$ via (\ref{EPA-x(x')}). The structure of the mapping is most obvious from: \begin{equation} x'(x) = \frac{\log x ( L - \log x) - \log x_0 (L - \log x_0)} {\log x_1 ( L - \log x_1) - \log x_0 (L - \log x_0)} \; . \end{equation} Taking the Eq. (6.16e) from the Budnev et al. report, and integrating it over $q^2$ yields the modified result \begin{equation} \label{EPA_616e} f(x) = \frac{\alpha}{\pi}\,q_p^2\, \frac{1}{x}\, \biggl[\left(\bar x + \frac{x^2}{2}\right) \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}} - x^2\frac{m^2}{Q^2_{\rm min}} \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right) \biggr]. \end{equation} This is closer to many standard papers from LEP times, and to textbook formulae like e.g. in Peskin/Schroeder. For historical reasons, we keep Eq.~(\ref{EPA_617}) as the default in \whizard. \subsection{The EPA data block} The EPA parameters are: $\alpha$, $E_{\rm max}$, $m$, $Q_{\rm min}$, and $x_{\rm min}$. Instead of $m$ we can use the incoming particle PDG code as input; from this we can deduce the mass and charge. Internally we store in addition $C_{0/1} = \frac{\alpha}{\pi}q_e^2\ln x_{0/1} (L - \ln x_{0/1})$, the c.m. energy squared and the incoming particle mass. <>= public :: EPA_MODE_DEFAULT public :: EPA_MODE_BUDNEV_617 public :: EPA_MODE_BUDNEV_616E public :: EPA_MODE_LOG_POWER public :: EPA_MODE_LOG_SIMPLE public :: EPA_MODE_LOG <>= integer, parameter :: EPA_MODE_DEFAULT = 0 integer, parameter :: EPA_MODE_BUDNEV_617 = 0 integer, parameter :: EPA_MODE_BUDNEV_616E = 1 integer, parameter :: EPA_MODE_LOG_POWER = 2 integer, parameter :: EPA_MODE_LOG_SIMPLE = 3 integer, parameter :: EPA_MODE_LOG = 4 @ %def EPA_MODE_DEFAULT EPA_MODE_BUDNEV_617 EPA_MODE_BUDNEV_616E @ %def EPA_MODE_LOG_POWER EPA_MODE_LOG_SIMPLE EPA_MODE_LOG @ <>= public :: epa_data_t <>= type, extends(sf_data_t) :: epa_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in real(default) :: alpha real(default) :: x_min real(default) :: x_max real(default) :: q_min real(default) :: q_max real(default) :: E_max real(default) :: mass real(default) :: log real(default) :: a real(default) :: c0 real(default) :: c1 real(default) :: dc integer :: mode = EPA_MODE_DEFAULT integer :: error = NONE logical :: recoil = .false. logical :: keep_energy = .true. contains <> end type epa_data_t @ %def epa_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_QMIN = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: ZERO_XMIN = 3 integer, parameter :: MASS_MIX = 4 integer, parameter :: NO_EPA = 5 <>= procedure :: init => epa_data_init <>= subroutine epa_data_init (data, model, mode, pdg_in, alpha, & x_min, q_min, q_max, mass, recoil, keep_energy) class(epa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in integer, intent(in) :: mode real(default), intent(in) :: alpha, x_min, q_min, q_max real(default), intent(in), optional :: mass logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy integer :: n_flv, i data%model => model data%mode = mode n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model) end do data%alpha = alpha data%E_max = q_max / 2 data%x_min = x_min data%x_max = 1 if (vanishes (data%x_min)) then data%error = ZERO_XMIN; return end if data%q_min = q_min data%q_max = q_max select case (char (data%model%get_name ())) case ("QCD","Test") data%error = NO_EPA; return end select if (present (recoil)) then data%recoil = recoil end if if (present (keep_energy)) then data%keep_energy = keep_energy end if if (present (mass)) then data%mass = mass else data%mass = data%flv_in(1)%get_mass () if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if if (max (data%mass, data%q_min) == 0) then data%error = ZERO_QMIN; return else if (max (data%mass, data%q_min) >= data%E_max) then data%error = Q_MAX_TOO_SMALL; return end if data%log = log ((data%q_max / max (data%mass, data%q_min)) ** 2 ) data%a = data%alpha / pi data%c0 = log (data%x_min) * (data%log - log (data%x_min)) data%c1 = log (data%x_max) * (data%log - log (data%x_max)) data%dc = data%c1 - data%c0 end subroutine epa_data_init @ %def epa_data_init @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => epa_data_check <>= subroutine epa_data_check (data) class(epa_data_t), intent(in) :: data select case (data%error) case (NO_EPA) call msg_fatal ("EPA structure function not available for model " & // char (data%model%get_name ()) // ".") case (ZERO_QMIN) call msg_fatal ("EPA: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("EPA: Particle mass exceeds Qmax") case (ZERO_XMIN) call msg_fatal ("EPA: x_min must be larger than zero") case (MASS_MIX) call msg_fatal ("EPA: incoming particle masses must be uniform") end select end subroutine epa_data_check @ %def epa_data_check @ Output <>= procedure :: write => epa_data_write <>= subroutine epa_data_write (data, unit, verbose) class(epa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "EPA data:" if (allocated (data%flv_in)) then write (u, "(3x,A)", advance="no") " flavor = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max write (u, "(3x,A," // FMT_19 // ")") " q_min = ", data%q_min write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max write (u, "(3x,A," // FMT_19 // ")") " E_max = ", data%e_max write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " a = ", data%a write (u, "(3x,A," // FMT_19 // ")") " c0 = ", data%c0 write (u, "(3x,A," // FMT_19 // ")") " c1 = ", data%c1 write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy else write (u, "(3x,A)") "[undefined]" end if end subroutine epa_data_write @ %def epa_data_write @ The number of kinematic parameters. <>= procedure :: get_n_par => epa_data_get_n_par <>= function epa_data_get_n_par (data) result (n) class(epa_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function epa_data_get_n_par @ %def epa_data_get_n_par @ Return the outgoing particles PDG codes. The outgoing particle is always the photon while the radiated particle is identical to the incoming one. <>= procedure :: get_pdg_out => epa_data_get_pdg_out <>= subroutine epa_data_get_pdg_out (data, pdg_out) class(epa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = PHOTON end subroutine epa_data_get_pdg_out @ %def epa_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => epa_data_allocate_sf_int <>= subroutine epa_data_allocate_sf_int (data, sf_int) class(epa_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (epa_t :: sf_int) end subroutine epa_data_allocate_sf_int @ %def epa_data_allocate_sf_int @ \subsection{The EPA object} The [[epa_t]] data type is a $1\to 2$ interaction. We should be able to handle several flavors in parallel, since EPA is not necessarily applied immediately after beam collision: Photons may be radiated from quarks. In that case, the partons are massless and $q_{\rm min}$ applies instead, so we do not need to generate several kinematical configurations in parallel. The squared charge values multiply the matrix elements, depending on the flavour. We scan the interaction after building it, so we have the correct assignments. The particles are ordered as (incoming, radiated, photon), where the photon initiates the hard interaction. We generate an unpolarized photon and transfer initial polarization to the radiated parton. Color is transferred in the same way. <>= type, extends (sf_int_t) :: epa_t type(epa_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb = 0 real(default) :: E = 0 real(default), dimension(:), allocatable :: charge2 contains <> end type epa_t @ %def epa_t @ Type string: has to be here, but there is no string variable on which EPA depends. Hence, a dummy routine. <>= procedure :: type_string => epa_type_string <>= function epa_type_string (object) result (string) class(epa_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "EPA: equivalent photon approx." else string = "EPA: [undefined]" end if end function epa_type_string @ %def epa_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => epa_write <>= subroutine epa_write (object, unit, testflag) class(epa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "E =", object%E end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "EPA data: [undefined]" end if end subroutine epa_write @ %def epa_write @ Prepare the interaction object. We have to construct transition matrix elements for all flavor and helicity combinations. <>= procedure :: init => epa_init <>= subroutine epa_init (sf_int, data) class(epa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc type(flavor_t) :: flv_photon type(color_t) :: col_photon type(quantum_numbers_t) :: qn_hel, qn_photon, qn, qn_rad type(polarization_iterator_t) :: it_hel integer :: i mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .false., .true.]) hel_lock = [2, 1, 0] select type (data) type is (epa_data_t) call sf_int%base_init (mask, [data%mass**2], & [data%mass**2], [0._default], hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col_photon%init () call qn_photon%init (flv_photon, col_photon) do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_photon]) call it_hel%advance () end do ! call pol%final () end do call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select end subroutine epa_init @ %def epa_init @ Prepare the charge array. This is separate from the previous routine since the state matrix may be helicity-contracted. <>= procedure :: setup_constants => epa_setup_constants <>= subroutine epa_setup_constants (sf_int) class(epa_t), intent(inout), target :: sf_int type(state_iterator_t) :: it type(flavor_t) :: flv integer :: i, n_me n_me = sf_int%get_n_matrix_elements () allocate (sf_int%charge2 (n_me)) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) sf_int%charge2(i) = flv%get_charge () ** 2 call it%advance () end do sf_int%status = SF_INITIAL end subroutine epa_setup_constants @ %def epa_setup_constants @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. The EPA structure function allows for a straightforward mapping of the unit interval. The $x$ value is transformed, and the mapped structure function becomes unity at its upper boundary. The structure function implementation applies the above mapping to the input (random) number [[r]] to generate the momentum fraction [[x]] and the function value [[f]]. For numerical stability reasons, we also output [[xb]], which is $\bar x=1-x$. <>= procedure :: complete_kinematics => epa_complete_kinematics <>= subroutine epa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: delta, sqrt_delta, lx if (map) then associate (data => sf_int%data) delta = data%log ** 2 - 4 * (r(1) * data%c1 + rb(1) * data%c0) if (delta > 0) then sqrt_delta = sqrt (delta) lx = (data%log - sqrt_delta) / 2 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if x(1) = exp (lx) f = x(1) * data%dc / sqrt_delta end associate else x(1) = r(1) if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then f = 1 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if end if xb(1) = 1 - x(1) if (size(x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) sf_int%xb= xb(1) sf_int%E = energy (sf_int%get_momentum (1)) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb= 0 f = 0 end select end subroutine epa_complete_kinematics @ %def epa_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of EPA, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. Note: the extraction of $\bar x$ is not numerically safe, but it cannot be as long as the base [[recover_x]] is not. <>= procedure :: recover_x => sf_epa_recover_x <>= subroutine sf_epa_recover_x (sf_int, x, xb, x_free) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_epa_recover_x @ %def sf_epa_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => epa_inverse_kinematics <>= subroutine epa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: lx, delta, sqrt_delta, c logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then associate (data => sf_int%data) lx = log (x(1)) sqrt_delta = data%log - 2 * lx delta = sqrt_delta ** 2 c = (data%log ** 2 - delta) / 4 r (1) = (c - data%c0) / data%dc rb(1) = (data%c1 - c) / data%dc f = x(1) * data%dc / sqrt_delta end associate else r (1) = x(1) rb(1) = xb(1) if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then f = 1 else f = 0 end if end if if (size(r) == 3) then r (2:3) = x(2:3) rb(2:3) = xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if sf_int%E = energy (sf_int%get_momentum (1)) end subroutine epa_inverse_kinematics @ %def epa_inverse_kinematics @ \subsection{EPA application} For EPA, we can in principle compute kinematics and function value in a single step. In order to be able to reweight events, kinematics and structure function application are separated. This function works on a single beam, assuming that the input momentum has been set. We need three random numbers as input: one for $x$, and two for the polar and azimuthal angles. Alternatively, for the no-recoil case, we can skip $p_T$ generation; in this case, we only need one. For obtaining splitting kinematics, we rely on the assumption that all in-particles are mass-degenerate (or there is only one), so the generated $x$ values are identical. Fix 2020-03-10: Divide by two if there is polarization. In the polarized case, the outgoing electron/positron retains the incoming polarization. The latter is summed over when convoluting with the beam, but there are still two states with different outgoing polarization but identical structure-function value. This leads to double-counting for the overall cross section. <>= procedure :: apply => epa_apply <>= subroutine epa_apply (sf_int, scale, negative_sf, rescale, i_sub) class(epa_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: x, xb, qminsq, qmaxsq, f, E, m2 associate (data => sf_int%data) x = sf_int%x xb= sf_int%xb E = sf_int%E m2 = data%mass ** 2 qminsq = max (x ** 2 / xb * data%mass ** 2, data%q_min ** 2) select case (data%mode) case (0) qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2) if (qminsq < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) & - (1 - x / 2) ** 2 & * log ((x**2 + qmaxsq / E ** 2) / (x**2 + qminsq / E ** 2)) & - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq)) else f = 0 end if case (1) qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2) if (qminsq < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) & - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq)) else f = 0 end if case (2) qmaxsq = data%q_max ** 2 if (data%mass ** 2 < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / m2) & - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq)) else f = 0 end if case (3) qmaxsq = data%q_max ** 2 if (data%mass ** 2 < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / m2) & - x ** 2 * (1 - m2 / qmaxsq)) else f = 0 end if case (4) qmaxsq = data%q_max ** 2 if (data%mass ** 2 < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / m2)) else f = 0 end if end select f = f / sf_int%get_n_matrix_elements () call sf_int%set_matrix_element & (cmplx (f, kind=default) * sf_int%charge2) end associate sf_int%status = SF_EVALUATED end subroutine epa_apply @ %def epa_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_epa_ut.f90]]>>= <> module sf_epa_ut use unit_tests use sf_epa_uti <> <> contains <> end module sf_epa_ut @ %def sf_epa_ut @ <<[[sf_epa_uti.f90]]>>= <> module sf_epa_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use interactions, only: interaction_pacify_momenta use model_data use sf_aux use sf_base use sf_epa <> <> contains <> end module sf_epa_uti @ %def sf_epa_ut @ API: driver for the unit tests below. <>= public :: sf_epa_test <>= subroutine sf_epa_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_epa_test @ %def sf_epa_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_epa_1, "sf_epa_1", & "structure function configuration", & u, results) <>= public :: sf_epa_1 <>= subroutine sf_epa_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_epa_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON allocate (epa_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_1" end subroutine sf_epa_1 @ %def sf_epa_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_epa_2, "sf_epa_2", & "structure function instance", & u, results) <>= public :: sf_epa_2 <>= subroutine sf_epa_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_2" end subroutine sf_epa_2 @ %def sf_epa_2 @ \subsubsection{Standard mapping} Construct and display a structure function object based on the EPA structure function, applying the standard single-particle mapping. <>= call test (sf_epa_3, "sf_epa_3", & "apply mapping", & u, results) <>= public :: sf_epa_3 <>= subroutine sf_epa_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, with EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_3" end subroutine sf_epa_3 @ %def sf_epa_3 @ \subsubsection{Non-collinear case} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_epa_4, "sf_epa_4", & "non-collinear", & u, results) <>= public :: sf_epa_4 <>= subroutine sf_epa_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E, m real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 5.0_default, recoil = .true.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500, me = 5 GeV" write (u, "(A)") E = 500 m = 5 k = vector4_moving (E, sqrt (E**2 - m**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EPA mapping, " write (u, "(A)") " non-coll., keeping energy, me = 5 GeV" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_4" end subroutine sf_epa_4 @ %def sf_epa_4 @ \subsubsection{Structure function for multiple flavors} Construct and display a structure function object based on the EPA structure function. The incoming state has multiple particles with non-uniform charge. <>= call test (sf_epa_5, "sf_epa_5", & "multiple flavors", & u, results) <>= public :: sf_epa_5 <>= subroutine sf_epa_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (1, model) pdg_in = [1, 2, -1, -2] call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) call data%check () end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_5" end subroutine sf_epa_5 @ %def sf_epa_5 @ \clearpage %------------------------------------------------------------------------ \section{EWA} <<[[sf_ewa.f90]]>>= <> module sf_ewa <> <> use io_units use constants, only: pi use format_defs, only: FMT_17, FMT_19 use numeric_utils use diagnostics use physics_defs, only: W_BOSON, Z_BOSON use lorentz use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use interactions use sf_aux use sf_base <> <> <> <> contains <> end module sf_ewa @ %def sf_ewa @ \subsection{Physics} The EWA structure function for a $Z$ or $W$ inside a fermion (lepton or quark) depends on the vector-boson polarization. We distinguish transversal ($\pm$) and longitudinal ($0$) polarization. \begin{align} F_{+}(x) &= \frac{1}{16\pi^2}\,\frac{(v-a)^2 + (v+a)^2\bar x^2}{x} \left[ \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right) - \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \right] \\ F_{-}(x) &= \frac{1}{16\pi^2}\,\frac{(v+a)^2 + (v-a)^2\bar x^2}{x} \left[ \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right) - \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \right] \\ F_0(x) &= \frac{v^2+a^2}{8\pi^2}\,\frac{2\bar x}{x}\, \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \end{align} where $p_{\perp,\textrm{max}}$ is the cutoff in transversal momentum, $M$ is the vector-boson mass, $v$ and $a$ are the vector and axial-vector couplings, and $\bar x\equiv 1-x$. Note that the longitudinal structure function is finite for large cutoff, while the transversal structure function is logarithmically divergent. The maximal transverse momentum is given by the kinematical limit, it is \begin{equation} p_{\perp,\textrm{max}} = \bar x \sqrt{s}/2. \end{equation} The vector and axial couplings for a fermion branching into a $W$ are \begin{align} v_W &= \frac{g}{2\sqrt 2}, & a_W &= \frac{g}{2\sqrt 2}. \end{align} For $Z$ emission, this is replaced by \begin{align} v_Z &= \frac{g}{2\cos\theta_w}\left(t_3 - 2q\sin^2\theta_w\right), & a_Z &= \frac{g}{2\cos\theta_w}t_3, \end{align} where $t_3=\pm\frac12$ is the fermion isospin, and $q$ its charge. For an initial antifermion, the signs of the axial couplings are inverted. Note that a common sign change of $v$ and $a$ is irrelevant. %% Differentiating with respect to the cutoff, we get structure functions %% \begin{align} %% f_{W,\pm}(x,p_T) &= \frac{g^2}{16\pi^2}\, %% \frac{1+\bar x^2}{x} %% \frac{p_\perp}{p_\perp^2 + \bar x M^2} %% \\ %% f_{W,0}(x,p_T) &= \frac{g^2}{16\pi^2}\, %% \frac{2\bar x}{x}\, %% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2} %% \\ %% F_{Z,\pm}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2} %% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\, %% \frac{1+\bar x^2}{x} %% \frac{p_\perp}{p_\perp^2 + \bar x M^2} %% \\ %% F_{Z,0}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2}\, %% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\, %% \frac{2\bar x}{x}\, %% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2} %% \end{align} %% Here, $t_3^f$ is the $SU(2)_L$ quantum number of the fermion %% $(\pm\frac12)$, and $q^f$ is the fermion charge in units of the %% positron charge. The EWA depends on the parameters $g$, $\sin^2\theta_w$, $M_W$, and $M_Z$. These can all be taken from the SM input, and the prefactors are calculated from those and the incoming particle type. Since these structure functions have a $1/x$ singularity (which is not really relevant in practice, however, since the vector boson mass is finite), we map this singularity allowing for nontrivial $x$ bounds: \begin{equation} x = \exp(\bar r\ln x_0 + r\ln x_1) \end{equation} such that \begin{equation} \int_{x_0}^{x_1}\frac{dx}{x} = (\ln x_1 - \ln x_0)\int_0^1 dr. \end{equation} As a user parameter, we have the cutoff $p_{\perp,\textrm{max}}$. The divergence $1/x$ also requires a $x_0$ cutoff; and for completeness we introduce a corresponding $x_1$. Physically, the minimal sensible value of $x$ is $M^2/s$, although the approximation loses its value already at higher $x$ values. \subsection{The EWA data block} The EWA parameters are: $p_{T,\rm max}$, $c_V$, $c_A$, and $m$. Instead of $m$ we can use the incoming particle PDG code as input; from this we can deduce the mass and charges. In the initialization phase it is not yet determined whether a $W$ or a $Z$ is radiated, hence we set the vector and axial-vector couplings equal to the common prefactors $g/2 = e/2/\sin\theta_W$. In principle, for EWA it would make sense to allow the user to also set the upper bound for $x$, $x_{\rm max}$, but we fix it to one here. <>= public :: ewa_data_t <>= type, extends(sf_data_t) :: ewa_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in type(flavor_t), dimension(:), allocatable :: flv_out real(default) :: pt_max real(default) :: sqrts real(default) :: x_min real(default) :: x_max real(default) :: mass real(default) :: m_out real(default) :: q_min real(default) :: cv real(default) :: ca real(default) :: costhw real(default) :: sinthw real(default) :: mW real(default) :: mZ real(default) :: coeff logical :: mass_set = .false. logical :: recoil = .false. logical :: keep_energy = .false. integer :: id = 0 integer :: error = NONE contains <> end type ewa_data_t @ %def ewa_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_QMIN = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: ZERO_XMIN = 3 integer, parameter :: MASS_MIX = 4 integer, parameter :: ZERO_SW = 5 integer, parameter :: ISOSPIN_MIX = 6 integer, parameter :: WRONG_PRT = 7 integer, parameter :: MASS_MIX_OUT = 8 integer, parameter :: NO_EWA = 9 <>= procedure :: init => ewa_data_init <>= subroutine ewa_data_init (data, model, pdg_in, x_min, pt_max, & sqrts, recoil, keep_energy, mass) class(ewa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: x_min, pt_max, sqrts logical, intent(in) :: recoil, keep_energy real(default), intent(in), optional :: mass real(default) :: g, ee integer :: n_flv, i data%model => model if (.not. any (pdg_in .match. & [1,2,3,4,5,6,11,13,15,-1,-2,-3,-4,-5,-6,-11,-13,-15])) then data%error = WRONG_PRT; return end if n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (n_flv)) allocate (data%flv_out(n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model) end do data%pt_max = pt_max data%sqrts = sqrts data%x_min = x_min data%x_max = 1 if (vanishes (data%x_min)) then data%error = ZERO_XMIN; return end if select case (char (data%model%get_name ())) case ("QCD","QED","Test") data%error = NO_EWA; return end select ee = data%model%get_real (var_str ("ee")) data%sinthw = data%model%get_real (var_str ("sw")) data%costhw = data%model%get_real (var_str ("cw")) data%mZ = data%model%get_real (var_str ("mZ")) data%mW = data%model%get_real (var_str ("mW")) if (data%sinthw /= 0) then g = ee / data%sinthw else data%error = ZERO_SW; return end if data%cv = g / 2._default data%ca = g / 2._default data%coeff = 1._default / (8._default * PI**2) data%recoil = recoil data%keep_energy = keep_energy if (present (mass)) then data%mass = mass data%m_out = mass data%mass_set = .true. else data%mass = data%flv_in(1)%get_mass () if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if end subroutine ewa_data_init @ %def ewa_data_init @ Set the vector boson ID for distinguishing $W$ and $Z$ bosons. <>= procedure :: set_id => ewa_set_id <>= subroutine ewa_set_id (data, id) class(ewa_data_t), intent(inout) :: data integer, intent(in) :: id integer :: i, isospin, pdg if (.not. allocated (data%flv_in)) & call msg_bug ("EWA: incoming particles not set") data%id = id select case (data%id) case (23) data%m_out = data%mass data%flv_out = data%flv_in case (24) do i = 1, size (data%flv_in) pdg = data%flv_in(i)%get_pdg () isospin = data%flv_in(i)%get_isospin_type () if (isospin > 0) then !!! up-type quark or neutrinos if (data%flv_in(i)%is_antiparticle ()) then call data%flv_out(i)%init (pdg + 1, data%model) else call data%flv_out(i)%init (pdg - 1, data%model) end if else !!! down-type quark or lepton if (data%flv_in(i)%is_antiparticle ()) then call data%flv_out(i)%init (pdg - 1, data%model) else call data%flv_out(i)%init (pdg + 1, data%model) end if end if end do if (.not. data%mass_set) then data%m_out = data%flv_out(1)%get_mass () if (any (data%flv_out%get_mass () /= data%m_out)) then data%error = MASS_MIX_OUT; return end if end if end select end subroutine ewa_set_id @ %def ewa_set_id @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => ewa_data_check <>= subroutine ewa_data_check (data) class(ewa_data_t), intent(in) :: data select case (data%error) case (WRONG_PRT) call msg_fatal ("EWA structure function only accessible for " & // "SM quarks and leptons.") case (NO_EWA) call msg_fatal ("EWA structure function not available for model " & // char (data%model%get_name ())) case (ZERO_SW) call msg_fatal ("EWA: Vanishing value of sin(theta_w)") case (ZERO_QMIN) call msg_fatal ("EWA: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("EWA: Particle mass exceeds Qmax") case (ZERO_XMIN) call msg_fatal ("EWA: x_min must be larger than zero") case (MASS_MIX) call msg_fatal ("EWA: incoming particle masses must be uniform") case (MASS_MIX_OUT) call msg_fatal ("EWA: outgoing particle masses must be uniform") case (ISOSPIN_MIX) call msg_fatal ("EWA: incoming particle isospins must be uniform") end select end subroutine ewa_data_check @ %def ewa_data_check @ Output <>= procedure :: write => ewa_data_write <>= subroutine ewa_data_write (data, unit, verbose) class(ewa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "EWA data:" if (allocated (data%flv_in) .and. allocated (data%flv_out)) then write (u, "(3x,A)", advance="no") " flavor(in) = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A)", advance="no") " flavor(out) = " do i = 1, size (data%flv_out) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_out(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max write (u, "(3x,A," // FMT_19 // ")") " pt_max = ", data%pt_max write (u, "(3x,A," // FMT_19 // ")") " sqrts = ", data%sqrts write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " cv = ", data%cv write (u, "(3x,A," // FMT_19 // ")") " ca = ", data%ca write (u, "(3x,A," // FMT_19 // ")") " coeff = ", data%coeff write (u, "(3x,A," // FMT_19 // ")") " costhw = ", data%costhw write (u, "(3x,A," // FMT_19 // ")") " sinthw = ", data%sinthw write (u, "(3x,A," // FMT_19 // ")") " mZ = ", data%mZ write (u, "(3x,A," // FMT_19 // ")") " mW = ", data%mW write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy write (u, "(3x,A,I2)") " PDG (VB) = ", data%id else write (u, "(3x,A)") "[undefined]" end if end subroutine ewa_data_write @ %def ewa_data_write @ The number of parameters is one for collinear splitting, in case the [[recoil]] option is set, we take the recoil into account. <>= procedure :: get_n_par => ewa_data_get_n_par <>= function ewa_data_get_n_par (data) result (n) class(ewa_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function ewa_data_get_n_par @ %def ewa_data_get_n_par @ Return the outgoing particles PDG codes. This depends, whether this is a charged-current or neutral-current interaction. <>= procedure :: get_pdg_out => ewa_data_get_pdg_out <>= subroutine ewa_data_get_pdg_out (data, pdg_out) class(ewa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: i, n_flv if (allocated (data%flv_out)) then n_flv = size (data%flv_out) else n_flv = 0 end if allocate (pdg1 (n_flv)) do i = 1, n_flv pdg1(i) = data%flv_out(i)%get_pdg () end do pdg_out(1) = pdg1 end subroutine ewa_data_get_pdg_out @ %def ewa_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => ewa_data_allocate_sf_int <>= subroutine ewa_data_allocate_sf_int (data, sf_int) class(ewa_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (ewa_t :: sf_int) end subroutine ewa_data_allocate_sf_int @ %def ewa_data_allocate_sf_int @ \subsection{The EWA object} The [[ewa_t]] data type is a $1\to 2$ interaction. We should be able to handle several flavors in parallel, since EWA is not necessarily applied immediately after beam collision: $W/Z$ bosons may be radiated from quarks. In that case, the partons are massless and $q_{\rm min}$ applies instead, so we do not need to generate several kinematical configurations in parallel. The particles are ordered as (incoming, radiated, W/Z), where the W/Z initiates the hard interaction. In the case of EPA, we generated an unpolarized photon and transferred initial polarization to the radiated parton. Color is transferred in the same way. I do not know whether the same can/should be done for EWA, as the structure functions depend on the W/Z polarization. If we are having $Z$ bosons, both up- and down-type fermions can participate. Otherwise, with a $W^+$ an up-type fermion is transferred to a down-type fermion, and the other way round. <>= type, extends (sf_int_t) :: ewa_t type(ewa_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb = 0 integer :: n_me = 0 real(default), dimension(:), allocatable :: cv real(default), dimension(:), allocatable :: ca contains <> end type ewa_t @ %def ewa_t @ Type string: has to be here, but there is no string variable on which EWA depends. Hence, a dummy routine. <>= procedure :: type_string => ewa_type_string <>= function ewa_type_string (object) result (string) class(ewa_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "EWA: equivalent W/Z approx." else string = "EWA: [undefined]" end if end function ewa_type_string @ %def ewa_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => ewa_write <>= subroutine ewa_write (object, unit, testflag) class(ewa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x write (u, "(3x,A," // FMT_17 // ")") "xb=", object%xb end if call object%base_write (u, testflag) else write (u, "(1x,A)") "EWA data: [undefined]" end if end subroutine ewa_write @ %def ewa_write @ The current implementation requires uniform isospin for all incoming particles, therefore we need to probe only the first one. <>= procedure :: init => ewa_init <>= subroutine ewa_init (sf_int, data) class(ewa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc, qn_fc_fin type(flavor_t) :: flv_z, flv_wp, flv_wm type(color_t) :: col0 type(quantum_numbers_t) :: qn_hel, qn_z, qn_wp, qn_wm, qn, qn_rad, qn_w type(polarization_iterator_t) :: it_hel integer :: i, isospin select type (data) type is (ewa_data_t) mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .false., .true.]) hel_lock = [2, 1, 0] call col0%init () select case (data%id) case (23) !!! Z boson, flavor is not changing call sf_int%base_init (mask, [data%mass**2], [data%mass**2], & [data%mZ**2], hel_lock = hel_lock) sf_int%data => data call flv_z%init (Z_BOSON, data%model) call qn_z%init (flv_z, col0) do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_z]) call it_hel%advance () end do ! call pol%final () end do case (24) call sf_int%base_init (mask, [data%mass**2], [data%m_out**2], & [data%mW**2], hel_lock = hel_lock) sf_int%data => data call flv_wp%init (W_BOSON, data%model) call flv_wm%init (- W_BOSON, data%model) call qn_wp%init (flv_wp, col0) call qn_wm%init (flv_wm, col0) do i = 1, size (data%flv_in) isospin = data%flv_in(i)%get_isospin_type () if (isospin > 0) then !!! up-type quark or neutrinos if (data%flv_in(i)%is_antiparticle ()) then qn_w = qn_wm else qn_w = qn_wp end if else !!! down-type quark or lepton if (data%flv_in(i)%is_antiparticle ()) then qn_w = qn_wp else qn_w = qn_wm end if end if call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call qn_fc_fin(1)%init ( & flv = data%flv_out(i), & col = color_from_flavor (data%flv_out(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn_hel .merge. qn_fc_fin(1) call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_w]) call it_hel%advance () end do ! call pol%final () end do case default call msg_fatal ("EWA initialization failed: wrong particle type.") end select call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select end subroutine ewa_init @ %def ewa_init @ Prepare the coupling arrays. This is separate from the previous routine since the state matrix may be helicity-contracted. <>= procedure :: setup_constants => ewa_setup_constants <>= subroutine ewa_setup_constants (sf_int) class(ewa_t), intent(inout), target :: sf_int type(state_iterator_t) :: it type(flavor_t) :: flv real(default) :: q, t3 integer :: i sf_int%n_me = sf_int%get_n_matrix_elements () allocate (sf_int%cv (sf_int%n_me)) allocate (sf_int%ca (sf_int%n_me)) associate (data => sf_int%data) select case (data%id) case (23) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) q = flv%get_charge () t3 = flv%get_isospin () if (flv%is_antiparticle ()) then sf_int%cv(i) = - data%cv & * (t3 - 2._default * q * data%sinthw**2) / data%costhw sf_int%ca(i) = data%ca * t3 / data%costhw else sf_int%cv(i) = data%cv & * (t3 - 2._default * q * data%sinthw**2) / data%costhw sf_int%ca(i) = data%ca * t3 / data%costhw end if call it%advance () end do case (24) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) if (flv%is_antiparticle ()) then sf_int%cv(i) = data%cv / sqrt(2._default) sf_int%ca(i) = - data%ca / sqrt(2._default) else sf_int%cv(i) = data%cv / sqrt(2._default) sf_int%ca(i) = data%ca / sqrt(2._default) end if call it%advance () end do end select end associate sf_int%status = SF_INITIAL end subroutine ewa_setup_constants @ %def ewa_setup_constants @ \subsection{Kinematics} Set kinematics. The EWA structure function allows for a straightforward mapping of the unit interval. So, to leading order, the structure function value is unity, but the $x$ value is transformed. Higher orders affect the function value. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, the exponential mapping for the $1/x$ singularity discussed above is applied. <>= procedure :: complete_kinematics => ewa_complete_kinematics <>= subroutine ewa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: e_1 real(default) :: x0, x1, lx0, lx1, lx e_1 = energy (sf_int%get_momentum (1)) if (sf_int%data%recoil) then select case (sf_int%data%id) case (23) x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1) case (24) x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1) end select else x0 = sf_int%data%x_min end if x1 = sf_int%data%x_max if ( x0 >= x1) then f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if if (map) then lx0 = log (x0) lx1 = log (x1) lx = lx1 * r(1) + lx0 * rb(1) x(1) = exp(lx) f = x(1) * (lx1 - lx0) else x(1) = r(1) if (x0 < x(1) .and. x(1) < x1) then f = 1 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if end if xb(1) = 1 - x(1) if (size(x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) sf_int%xb = xb(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb = 0 f = 0 end select end subroutine ewa_complete_kinematics @ %def ewa_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of EWA, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. <>= procedure :: recover_x => sf_ewa_recover_x <>= subroutine sf_ewa_recover_x (sf_int, x, xb, x_free) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_ewa_recover_x @ %def sf_ewa_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => ewa_inverse_kinematics <>= subroutine ewa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: x0, x1, lx0, lx1, lx, e_1 logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta e_1 = energy (sf_int%get_momentum (1)) if (sf_int%data%recoil) then select case (sf_int%data%id) case (23) x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1) case (24) x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1) end select else x0 = sf_int%data%x_min end if x1 = sf_int%data%x_max if (map) then lx0 = log (x0) lx1 = log (x1) lx = log (x(1)) r(1) = (lx - lx0) / (lx1 - lx0) rb(1) = (lx1 - lx) / (lx1 - lx0) f = x(1) * (lx1 - lx0) else r (1) = x(1) rb(1) = 1 - x(1) if (x0 < x(1) .and. x(1) < x1) then f = 1 else f = 0 end if end if if (size(r) == 3) then r (2:3) = x(2:3) rb(2:3) = xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine ewa_inverse_kinematics @ %def ewa_inverse_kinematics @ \subsection{EWA application} For EWA, we can compute kinematics and function value in a single step. This function works on a single beam, assuming that the input momentum has been set. We need four random numbers as input: one for $x$, one for $Q^2$, and two for the polar and azimuthal angles. Alternatively, we can skip $p_T$ generation; in this case, we only need one. For obtaining splitting kinematics, we rely on the assumption that all in-particles are mass-degenerate (or there is only one), so the generated $x$ values are identical. <>= procedure :: apply => ewa_apply <>= subroutine ewa_apply (sf_int, scale, negative_sf, rescale, i_sub) class(ewa_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: x, xb, pt2, c1, c2 real(default) :: cv, ca real(default) :: f, fm, fp, fL integer :: i associate (data => sf_int%data) x = sf_int%x xb = sf_int%xb pt2 = min ((data%pt_max)**2, (xb * data%sqrts / 2)**2) select case (data%id) case (23) !!! Z boson structure function c1 = log (1 + pt2 / (xb * (data%mZ)**2)) c2 = 1 / (1 + (xb * (data%mZ)**2) / pt2) case (24) !!! W boson structure function c1 = log (1 + pt2 / (xb * (data%mW)**2)) c2 = 1 / (1 + (xb * (data%mW)**2) / pt2) end select do i = 1, sf_int%n_me cv = sf_int%cv(i) ca = sf_int%ca(i) fm = data%coeff * & ((cv + ca)**2 + ((cv - ca) * xb)**2) * (c1 - c2) / (2 * x) fp = data%coeff * & ((cv - ca)**2 + ((cv + ca) * xb)**2) * (c1 - c2) / (2 * x) fL = data%coeff * & (cv**2 + ca**2) * (2 * xb / x) * c2 f = fp + fm + fL if (.not. vanishes (f)) then fp = fp / f fm = fm / f fL = fL / f end if call sf_int%set_matrix_element (i, cmplx (f, kind=default)) end do end associate sf_int%status = SF_EVALUATED end subroutine ewa_apply @ %def ewa_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_ewa_ut.f90]]>>= <> module sf_ewa_ut use unit_tests use sf_ewa_uti <> <> contains <> end module sf_ewa_ut @ %def sf_ewa_ut @ <<[[sf_ewa_uti.f90]]>>= <> module sf_ewa_uti <> use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use interactions, only: interaction_pacify_momenta use model_data use sf_aux use sf_base use sf_ewa <> <> contains <> end module sf_ewa_uti @ %def sf_ewa_ut @ API: driver for the unit tests below. <>= public :: sf_ewa_test <>= subroutine sf_ewa_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_ewa_test @ %def sf_ewa_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_ewa_1, "sf_ewa_1", & "structure function configuration", & u, results) <>= public :: sf_ewa_1 <>= subroutine sf_ewa_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_ewa_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_sm_test () pdg_in = 2 allocate (ewa_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize for Z boson" write (u, "(A)") select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 5000._default, .false., .false.) call data%set_id (23) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 write (u, "(A)") write (u, "(A)") "* Initialize for W boson" write (u, "(A)") deallocate (data) allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 5000._default, .false., .false.) call data%set_id (24) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_1" end subroutine sf_ewa_1 @ %def sf_ewa_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the EWA structure function. <>= call test (sf_ewa_2, "sf_ewa_2", & "structure function instance", & u, results) <>= public :: sf_ewa_2 <>= subroutine sf_ewa_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_2" end subroutine sf_ewa_2 @ %def sf_ewa_2 @ \subsubsection{Standard mapping} Construct and display a structure function object based on the EWA structure function, applying the standard single-particle mapping. <>= call test (sf_ewa_3, "sf_ewa_3", & "apply mapping", & u, results) <>= public :: sf_ewa_3 <>= subroutine sf_ewa_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, with EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_3" end subroutine sf_ewa_3 @ %def sf_ewa_3 @ \subsubsection{Non-collinear case} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_ewa_4, "sf_ewa_4", & "non-collinear", & u, results) <>= public :: sf_ewa_4 <>= subroutine sf_ewa_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call modeL%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000.0_default, .true., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EWA mapping, " write (u, "(A)") " non-coll., keeping energy" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 1500._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_4" end subroutine sf_ewa_4 @ %def sf_ewa_4 @ \subsubsection{Structure function for multiple flavors} Construct and display a structure function object based on the EWA structure function. The incoming state has multiple particles with non-uniform quantum numbers. <>= call test (sf_ewa_5, "sf_ewa_5", & "structure function instance", & u, results) <>= public :: sf_ewa_5 <>= subroutine sf_ewa_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = [1, 2, -1, -2] call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_5" end subroutine sf_ewa_5 @ %def sf_ewa_5 @ \clearpage %------------------------------------------------------------------------ \section{Energy-scan spectrum} This spectrum is actually a trick that allows us to plot the c.m.\ energy dependence of a cross section without scanning the input energy. We start with the observation that a spectrum $f(x)$, applied to one of the incoming beams only, results in a cross section \begin{equation} \sigma = \int dx\,f(x)\,\hat\sigma(xs). \end{equation} We want to compute the distribution of $E=\sqrt{\hat s}=\sqrt{xs}$, i.e., \begin{equation} \frac{d\sigma}{dE} = \frac{2\sqrt{x}}{\sqrt{s}}\,\frac{d\sigma}{dx} = \frac{2\sqrt{x}}{\sqrt{s}}\,f(x)\,\hat\sigma(xs), \end{equation} so if we set \begin{equation} f(x) = \frac{\sqrt{s}}{2\sqrt{x}}, \end{equation} we get the distribution \begin{equation} \frac{d\sigma}{dE} = \hat\sigma(\hat s=E^2). \end{equation} We implement this as a spectrum with a single parameter $x$. The parameters for the individual beams are computed as $x_i=\sqrt{x}$, so they are equal and the kinematics is always symmetric. <<[[sf_escan.f90]]>>= <> module sf_escan <> <> use io_units use format_defs, only: FMT_12 use numeric_utils use diagnostics use lorentz use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> contains <> end module sf_escan @ %def sf_escan @ \subsection{Data type} The [[norm]] is unity if the total cross section should be normalized to one, and $\sqrt{s}$ if it should be normalized to the total energy. In the latter case, the differential distribution $d\sigma/d\sqrt{\hat s}$ coincides with the partonic cross section $\hat\sigma$ as a function of $\sqrt{\hat s}$. <>= public :: escan_data_t <>= type, extends(sf_data_t) :: escan_data_t private type(flavor_t), dimension(:,:), allocatable :: flv_in integer, dimension(2) :: n_flv = 0 real(default) :: norm = 1 contains <> end type escan_data_t @ %def escan_data_t <>= procedure :: init => escan_data_init <>= subroutine escan_data_init (data, model, pdg_in, norm) class(escan_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in), optional :: norm real(default), dimension(2) :: m2 integer :: i, j data%n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (maxval (data%n_flv), 2)) do i = 1, 2 do j = 1, data%n_flv(i) call data%flv_in(j, i)%init (pdg_array_get (pdg_in(i), j), model) end do end do m2 = data%flv_in(1,:)%get_mass () do i = 1, 2 if (.not. any (nearly_equal (data%flv_in(1:data%n_flv(i),i)%get_mass (), m2(i)))) then call msg_fatal ("Energy scan: incoming particle mass must be uniform") end if end do if (present (norm)) data%norm = norm end subroutine escan_data_init @ %def escan_data_init @ Output <>= procedure :: write => escan_data_write <>= subroutine escan_data_write (data, unit, verbose) class(escan_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i, j u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Energy-scan data:" write (u, "(3x,A)", advance="no") "prt_in = " do i = 1, 2 if (i > 1) write (u, "(',',1x)", advance="no") do j = 1, data%n_flv(i) if (j > 1) write (u, "(':')", advance="no") write (u, "(A)", advance="no") char (data%flv_in(j,i)%get_name ()) end do end do write (u, *) write (u, "(3x,A," // FMT_12 // ")") "norm =", data%norm end subroutine escan_data_write @ %def escan_data_write @ Kinematics is completely collinear, hence there is only one parameter for a pair spectrum. <>= procedure :: get_n_par => escan_data_get_n_par <>= function escan_data_get_n_par (data) result (n) class(escan_data_t), intent(in) :: data integer :: n n = 1 end function escan_data_get_n_par @ %def escan_data_get_n_par @ Return the outgoing particles PDG codes. This is always the same as the incoming particle, where we use two indices for the two beams. <>= procedure :: get_pdg_out => escan_data_get_pdg_out <>= subroutine escan_data_get_pdg_out (data, pdg_out) class(escan_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(1:data%n_flv(i),i)%get_pdg () end do end subroutine escan_data_get_pdg_out @ %def escan_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => escan_data_allocate_sf_int <>= subroutine escan_data_allocate_sf_int (data, sf_int) class(escan_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (escan_t :: sf_int) end subroutine escan_data_allocate_sf_int @ %def escan_data_allocate_sf_int @ \subsection{The Energy-scan object} This is a spectrum, not a radiation. We create an interaction with two incoming and two outgoing particles, flavor, color, and helicity being carried through. $x$ nevertheless is only one-dimensional, as we are always using only one beam parameter. <>= type, extends (sf_int_t) :: escan_t type(escan_data_t), pointer :: data => null () contains <> end type escan_t @ %def escan_t @ Type string: for the energy scan this is just a dummy function. <>= procedure :: type_string => escan_type_string <>= function escan_type_string (object) result (string) class(escan_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Escan: energy scan" else string = "Escan: [undefined]" end if end function escan_type_string @ %def escan_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => escan_write <>= subroutine escan_write (object, unit, testflag) class(escan_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "Energy scan data: [undefined]" end if end subroutine escan_write @ %def escan_write @ <>= procedure :: init => escan_init <>= subroutine escan_init (sf_int, data) class(escan_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: j1, j2 select type (data) type is (escan_data_t) hel_lock = [3, 4, 1, 2] m2 = data%flv_in(1,:)%get_mass () call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do j1 = 1, data%n_flv(1) call qn_fc(1)%init ( & flv = data%flv_in(j1,1), & col = color_from_flavor (data%flv_in(j1,1))) call qn_fc(3)%init ( & flv = data%flv_in(j1,1), & col = color_from_flavor (data%flv_in(j1,1))) call pol1%init_generic (data%flv_in(j1,1)) do j2 = 1, data%n_flv(2) call qn_fc(2)%init ( & flv = data%flv_in(j2,2), & col = color_from_flavor (data%flv_in(j2,2))) call qn_fc(4)%init ( & flv = data%flv_in(j2,2), & col = color_from_flavor (data%flv_in(j2,2))) call pol2%init_generic (data%flv_in(j2,2)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol2%final () end do ! call pol1%final () end do call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%freeze () sf_int%status = SF_INITIAL end select end subroutine escan_init @ %def escan_init @ \subsection{Kinematics} Set kinematics. We have a single parameter, but reduce both beams. The [[map]] flag is ignored. <>= procedure :: complete_kinematics => escan_complete_kinematics <>= subroutine escan_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default) :: sqrt_x real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb= rb sqrt_x = sqrt (x(1)) if (sqrt_x > 0) then f = 1 / (2 * sqrt_x) else f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if call sf_int%reduce_momenta ([sqrt_x, sqrt_x]) end subroutine escan_complete_kinematics @ %def escan_complete_kinematics @ Recover $x$. The base procedure should return two momentum fractions for the two beams, while we have only one parameter. This is the product of the extracted momentum fractions. <>= procedure :: recover_x => escan_recover_x <>= subroutine escan_recover_x (sf_int, x, xb, x_free) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: xi, xib call sf_int%base_recover_x (xi, xib, x_free) x = product (xi) xb= 1 - x end subroutine escan_recover_x @ %def escan_recover_x @ Compute inverse kinematics. <>= procedure :: inverse_kinematics => escan_inverse_kinematics <>= subroutine escan_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: sqrt_x logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta sqrt_x = sqrt (x(1)) if (sqrt_x > 0) then f = 1 / (2 * sqrt_x) else f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if r = x rb = xb if (set_mom) then call sf_int%reduce_momenta ([sqrt_x, sqrt_x]) end if end subroutine escan_inverse_kinematics @ %def escan_inverse_kinematics @ \subsection{Energy scan application} Here, we insert the predefined norm. <>= procedure :: apply => escan_apply <>= subroutine escan_apply (sf_int, scale, negative_sf, rescale, i_sub) class(escan_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f associate (data => sf_int%data) f = data%norm end associate call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine escan_apply @ %def escan_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_escan_ut.f90]]>>= <> module sf_escan_ut use unit_tests use sf_escan_uti <> <> contains <> end module sf_escan_ut @ %def sf_escan_ut @ <<[[sf_escan_uti.f90]]>>= <> module sf_escan_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_escan <> <> contains <> end module sf_escan_uti @ %def sf_escan_ut @ API: driver for the unit tests below. <>= public :: sf_escan_test <>= subroutine sf_escan_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_escan_test @ %def sf_escan_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_escan_1, "sf_escan_1", & "structure function configuration", & u, results) <>= public :: sf_escan_1 <>= subroutine sf_escan_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_escan_1" write (u, "(A)") "* Purpose: initialize and display & &energy-scan structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (escan_data_t :: data) select type (data) type is (escan_data_t) call data%init (model, pdg_in, norm = 2._default) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_escan_1" end subroutine sf_escan_1 @ %def sf_escan_1 g@ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_escan_2, "sf_escan_2", & "generate event", & u, results) <>= public :: sf_escan_2 <>= subroutine sf_escan_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f write (u, "(A)") "* Test output: sf_escan_2" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (escan_data_t :: data) select type (data) type is (escan_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.8 rb = 1 - r x_free = 1 call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call sf_int%recover_x (x, xb, x_free) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_escan_2" end subroutine sf_escan_2 @ %def sf_escan_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Gaussian beam spread} Instead of an analytic beam description, beam data may be provided in form of an event file. In its most simple form, the event file contains pairs of $x$ values, relative to nominal beam energies. More advanced formats may include polarization, etc. The current implementation carries beam polarization through, if specified. The code is very similar to the energy scan described above. However, we must include a file-handle manager for the beam-event files. Two different processes may access a given beam-event file at the same time (i.e., serially but alternating). Accessing an open file from two different units is non-standard and not supported by all compilers. Therefore, we keep a global registry of open files, associated units, and reference counts. The [[gaussian_t]] objects act as proxies to this registry. <<[[sf_gaussian.f90]]>>= <> module sf_gaussian <> <> use io_units use format_defs, only: FMT_12 use file_registries use diagnostics use lorentz use rng_base use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> contains <> end module sf_gaussian @ %def sf_gaussian @ \subsection{The beam-data file registry} We manage data files via the [[file_registries]] module. To this end, we keep the registry as a private module variable here. <>= type(file_registry_t), save :: beam_file_registry @ %def beam_file_registry @ \subsection{Data type} We store the spread for each beam, as a relative number related to the beam energy. For the actual generation, we include an (abstract) random-number generator factory. <>= public :: gaussian_data_t <>= type, extends(sf_data_t) :: gaussian_data_t private type(flavor_t), dimension(2) :: flv_in real(default), dimension(2) :: spread class(rng_factory_t), allocatable :: rng_factory contains <> end type gaussian_data_t @ %def gaussian_data_t <>= procedure :: init => gaussian_data_init <>= subroutine gaussian_data_init (data, model, pdg_in, spread, rng_factory) class(gaussian_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), dimension(2), intent(in) :: spread class(rng_factory_t), intent(inout), allocatable :: rng_factory if (any (spread < 0)) then call msg_fatal ("Gaussian beam spread: must not be negative") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%spread = spread call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine gaussian_data_init @ %def gaussian_data_init @ Return true since this spectrum is always in generator mode. <>= procedure :: is_generator => gaussian_data_is_generator <>= function gaussian_data_is_generator (data) result (flag) class(gaussian_data_t), intent(in) :: data logical :: flag flag = .true. end function gaussian_data_is_generator @ %def gaussian_data_is_generator @ The number of parameters is two. They are free parameters. <>= procedure :: get_n_par => gaussian_data_get_n_par <>= function gaussian_data_get_n_par (data) result (n) class(gaussian_data_t), intent(in) :: data integer :: n n = 2 end function gaussian_data_get_n_par @ %def gaussian_data_get_n_par <>= procedure :: get_pdg_out => gaussian_data_get_pdg_out <>= subroutine gaussian_data_get_pdg_out (data, pdg_out) class(gaussian_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(i)%get_pdg () end do end subroutine gaussian_data_get_pdg_out @ %def gaussian_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => gaussian_data_allocate_sf_int <>= subroutine gaussian_data_allocate_sf_int (data, sf_int) class(gaussian_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (gaussian_t :: sf_int) end subroutine gaussian_data_allocate_sf_int @ %def gaussian_data_allocate_sf_int @ Output <>= procedure :: write => gaussian_data_write <>= subroutine gaussian_data_write (data, unit, verbose) class(gaussian_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Gaussian beam spread data:" write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,2(1x," // FMT_12 // "))") "spread =", data%spread call data%rng_factory%write (u) end subroutine gaussian_data_write @ %def gaussian_data_write @ \subsection{The gaussian object} Flavor and polarization carried through, no radiated particles. The generator needs a random-number generator, obviously. <>= public :: gaussian_t <>= type, extends (sf_int_t) :: gaussian_t type(gaussian_data_t), pointer :: data => null () class(rng_t), allocatable :: rng contains <> end type gaussian_t @ %def gaussian_t @ Type string: show gaussian file. <>= procedure :: type_string => gaussian_type_string <>= function gaussian_type_string (object) result (string) class(gaussian_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Gaussian: gaussian beam-energy spread" else string = "Gaussian: [undefined]" end if end function gaussian_type_string @ %def gaussian_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => gaussian_write <>= subroutine gaussian_write (object, unit, testflag) class(gaussian_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%rng%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "gaussian data: [undefined]" end if end subroutine gaussian_write @ %def gaussian_write @ <>= procedure :: init => gaussian_init <>= subroutine gaussian_init (sf_int, data) class(gaussian_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: i select type (data) type is (gaussian_data_t) m2 = data%flv_in%get_mass () ** 2 hel_lock = [3, 4, 1, 2] mask = quantum_numbers_mask (.false., .false., .false.) call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do i = 1, 2 call qn_fc(i)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) call qn_fc(i+2)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) end do call pol1%init_generic (data%flv_in(1)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call pol2%init_generic (data%flv_in(2)) call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do ! call pol2%final () call it_hel1%advance () end do ! call pol1%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) sf_int%status = SF_INITIAL end select call sf_int%data%rng_factory%make (sf_int%rng) end subroutine gaussian_init @ %def gaussian_init @ This spectrum type needs a finalizer, which closes the data file. <>= procedure :: final => sf_gaussian_final <>= subroutine sf_gaussian_final (object) class(gaussian_t), intent(inout) :: object call object%interaction_t%final () end subroutine sf_gaussian_final @ %def sf_gaussian_final @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => gaussian_is_generator <>= function gaussian_is_generator (sf_int) result (flag) class(gaussian_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function gaussian_is_generator @ %def gaussian_is_generator @ Generate free parameters. The $x$ value should be distributed with mean $1$ and $\sigma$ given by the spread. We reject negative $x$ values. (This cut slightly biases the distribution, but for reasonable (small) spreads negative $r$ should not occur. <>= procedure :: generate_free => gaussian_generate_free <>= subroutine gaussian_generate_free (sf_int, r, rb, x_free) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free real(default), dimension(size(r)) :: z associate (data => sf_int%data) do call sf_int%rng%generate_gaussian (z) rb = z * data%spread r = 1 - rb x_free = x_free * product (r) if (all (r > 0)) exit end do end associate end subroutine gaussian_generate_free @ %def gaussian_generate_free @ Set kinematics. Trivial transfer since this is a pure generator. The [[map]] flag doesn't apply. <>= procedure :: complete_kinematics => gaussian_complete_kinematics <>= subroutine gaussian_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("gaussian: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine gaussian_complete_kinematics @ %def gaussian_complete_kinematics @ Compute inverse kinematics. Trivial in this case. <>= procedure :: inverse_kinematics => gaussian_inverse_kinematics <>= subroutine gaussian_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("gaussian: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine gaussian_inverse_kinematics @ %def gaussian_inverse_kinematics @ \subsection{gaussian application} Trivial, just set the unit weight. <>= procedure :: apply => gaussian_apply <>= subroutine gaussian_apply (sf_int, scale, negative_sf, rescale, i_sub) class(gaussian_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f f = 1 call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine gaussian_apply @ %def gaussian_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_gaussian_ut.f90]]>>= <> module sf_gaussian_ut use unit_tests use sf_gaussian_uti <> <> contains <> end module sf_gaussian_ut @ %def sf_gaussian_ut @ <<[[sf_gaussian_uti.f90]]>>= <> module sf_gaussian_uti <> + use numeric_utils, only: pacify use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_gaussian use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_gaussian_uti @ %def sf_gaussian_ut @ API: driver for the unit tests below. <>= public :: sf_gaussian_test <>= subroutine sf_gaussian_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_gaussian_test @ %def sf_gaussian_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_gaussian_1, "sf_gaussian_1", & "structure function configuration", & u, results) <>= public :: sf_gaussian_1 <>= subroutine sf_gaussian_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data class(rng_factory_t), allocatable :: rng_factory write (u, "(A)") "* Test output: sf_gaussian_1" write (u, "(A)") "* Purpose: initialize and display & &gaussian-spread structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (gaussian_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (gaussian_data_t) call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_gaussian_1" end subroutine sf_gaussian_1 @ %def sf_gaussian_1 @ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_gaussian_2, "sf_gaussian_2", & "generate event", & u, results) <>= public :: sf_gaussian_2 <>= subroutine sf_gaussian_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f integer :: i write (u, "(A)") "* Test output: sf_gaussian_2" write (u, "(A)") "* Purpose: initialize and display & &gaussian-spread structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (gaussian_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (gaussian_data_t) call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call pacify (rb, 1.e-8_default) call pacify (xb, 1.e-8_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Generate more events" write (u, "(A)") select type (sf_int) type is (gaussian_t) do i = 1, 3 call sf_int%generate_free (r, rb, x_free) write (u, "(A,9(1x,F10.7))") "r =", r end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_gaussian_2" end subroutine sf_gaussian_2 @ %def sf_gaussian_2 @ \clearpage @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Using beam event data} Instead of an analytic beam description, beam data may be provided in form of an event file. In its most simple form, the event file contains pairs of $x$ values, relative to nominal beam energies. More advanced formats may include polarization, etc. The current implementation carries beam polarization through, if specified. The code is very similar to the energy scan described above. However, we must include a file-handle manager for the beam-event files. Two different processes may access a given beam-event file at the same time (i.e., serially but alternating). Accessing an open file from two different units is non-standard and not supported by all compilers. Therefore, we keep a global registry of open files, associated units, and reference counts. The [[beam_events_t]] objects act as proxies to this registry. <<[[sf_beam_events.f90]]>>= <> module sf_beam_events <> <> use io_units use file_registries use diagnostics use lorentz use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> <> contains <> end module sf_beam_events @ %def sf_beam_events @ \subsection{The beam-data file registry} We manage data files via the [[file_registries]] module. To this end, we keep the registry as a private module variable here. This is public only for the unit tests. <>= public :: beam_file_registry <>= type(file_registry_t), save :: beam_file_registry @ %def beam_file_registry @ \subsection{Data type} <>= public :: beam_events_data_t <>= type, extends(sf_data_t) :: beam_events_data_t private type(flavor_t), dimension(2) :: flv_in type(string_t) :: dir type(string_t) :: file type(string_t) :: fqn integer :: unit = 0 logical :: warn_eof = .true. contains <> end type beam_events_data_t @ %def beam_events_data_t <>= procedure :: init => beam_events_data_init <>= subroutine beam_events_data_init (data, model, pdg_in, dir, file, warn_eof) class(beam_events_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in type(string_t), intent(in) :: dir type(string_t), intent(in) :: file logical, intent(in), optional :: warn_eof if (any (pdg_array_get_length (pdg_in) /= 1)) then call msg_fatal ("Beam events: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%dir = dir data%file = file if (present (warn_eof)) data%warn_eof = warn_eof end subroutine beam_events_data_init @ %def beam_events_data_init @ Return true since this spectrum is always in generator mode. <>= procedure :: is_generator => beam_events_data_is_generator <>= function beam_events_data_is_generator (data) result (flag) class(beam_events_data_t), intent(in) :: data logical :: flag flag = .true. end function beam_events_data_is_generator @ %def beam_events_data_is_generator @ The number of parameters is two. They are free parameters. <>= procedure :: get_n_par => beam_events_data_get_n_par <>= function beam_events_data_get_n_par (data) result (n) class(beam_events_data_t), intent(in) :: data integer :: n n = 2 end function beam_events_data_get_n_par @ %def beam_events_data_get_n_par <>= procedure :: get_pdg_out => beam_events_data_get_pdg_out <>= subroutine beam_events_data_get_pdg_out (data, pdg_out) class(beam_events_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(i)%get_pdg () end do end subroutine beam_events_data_get_pdg_out @ %def beam_events_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => beam_events_data_allocate_sf_int <>= subroutine beam_events_data_allocate_sf_int (data, sf_int) class(beam_events_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (beam_events_t :: sf_int) end subroutine beam_events_data_allocate_sf_int @ %def beam_events_data_allocate_sf_int @ Output <>= procedure :: write => beam_events_data_write <>= subroutine beam_events_data_write (data, unit, verbose) class(beam_events_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Beam-event file data:" write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,A,A)") "file = '", char (data%file), "'" write (u, "(3x,A,I0)") "unit = ", data%unit write (u, "(3x,A,L1)") "warn = ", data%warn_eof end subroutine beam_events_data_write @ %def beam_events_data_write @ The data file needs to be opened and closed explicitly. The open/close message is communicated to the file handle registry, which does the actual work. We determine first whether to look in the local directory or in the given system directory. <>= procedure :: open => beam_events_data_open procedure :: close => beam_events_data_close <>= subroutine beam_events_data_open (data) class(beam_events_data_t), intent(inout) :: data logical :: exist if (data%unit == 0) then data%fqn = data%file if (data%fqn == "") & call msg_fatal ("Beam events: $beam_events_file is not set") inquire (file = char (data%fqn), exist = exist) if (.not. exist) then data%fqn = data%dir // "/" // data%file inquire (file = char (data%fqn), exist = exist) if (.not. exist) then data%fqn = "" call msg_fatal ("Beam events: file '" & // char (data%file) // "' not found") return end if end if call msg_message ("Beam events: reading from file '" & // char (data%file) // "'") call beam_file_registry%open (data%fqn, data%unit) else call msg_bug ("Beam events: file '" & // char (data%file) // "' is already open") end if end subroutine beam_events_data_open subroutine beam_events_data_close (data) class(beam_events_data_t), intent(inout) :: data if (data%unit /= 0) then call beam_file_registry%close (data%fqn) call msg_message ("Beam events: closed file '" & // char (data%file) // "'") data%unit = 0 end if end subroutine beam_events_data_close @ %def beam_events_data_close @ Return the beam event file. <>= procedure :: get_beam_file => beam_events_data_get_beam_file <>= function beam_events_data_get_beam_file (data) result (file) class(beam_events_data_t), intent(in) :: data type(string_t) :: file file = "Beam events: " // data%file end function beam_events_data_get_beam_file @ %def beam_events_data_get_beam_file @ \subsection{The beam events object} Flavor and polarization carried through, no radiated particles. <>= public :: beam_events_t <>= type, extends (sf_int_t) :: beam_events_t type(beam_events_data_t), pointer :: data => null () integer :: count = 0 contains <> end type beam_events_t @ %def beam_events_t @ Type string: show beam events file. <>= procedure :: type_string => beam_events_type_string <>= function beam_events_type_string (object) result (string) class(beam_events_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Beam events: " // object%data%file else string = "Beam events: [undefined]" end if end function beam_events_type_string @ %def beam_events_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => beam_events_write <>= subroutine beam_events_write (object, unit, testflag) class(beam_events_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "Beam events data: [undefined]" end if end subroutine beam_events_write @ %def beam_events_write @ <>= procedure :: init => beam_events_init <>= subroutine beam_events_init (sf_int, data) class(beam_events_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: i select type (data) type is (beam_events_data_t) m2 = data%flv_in%get_mass () ** 2 hel_lock = [3, 4, 1, 2] mask = quantum_numbers_mask (.false., .false., .false.) call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do i = 1, 2 call qn_fc(i)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) call qn_fc(i+2)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) end do call pol1%init_generic (data%flv_in(1)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call pol2%init_generic (data%flv_in(2)) call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do ! call pol2%final () call it_hel1%advance () end do ! call pol1%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%data%open () sf_int%status = SF_INITIAL end select end subroutine beam_events_init @ %def beam_events_init @ This spectrum type needs a finalizer, which closes the data file. <>= procedure :: final => sf_beam_events_final <>= subroutine sf_beam_events_final (object) class(beam_events_t), intent(inout) :: object call object%data%close () call object%interaction_t%final () end subroutine sf_beam_events_final @ %def sf_beam_events_final @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => beam_events_is_generator <>= function beam_events_is_generator (sf_int) result (flag) class(beam_events_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function beam_events_is_generator @ %def beam_events_is_generator @ Generate free parameters. We read them from file. <>= procedure :: generate_free => beam_events_generate_free <>= recursive subroutine beam_events_generate_free (sf_int, r, rb, x_free) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free integer :: iostat associate (data => sf_int%data) if (data%unit /= 0) then read (data%unit, fmt=*, iostat=iostat) r if (iostat > 0) then write (msg_buffer, "(A,I0,A)") & "Beam events: I/O error after reading ", sf_int%count, & " events" call msg_fatal () else if (iostat < 0) then if (sf_int%count == 0) then call msg_fatal ("Beam events: file is empty") else if (sf_int%data%warn_eof) then write (msg_buffer, "(A,I0,A)") & "Beam events: End of file after reading ", sf_int%count, & " events, rewinding" call msg_warning () end if rewind (data%unit) sf_int%count = 0 call sf_int%generate_free (r, rb, x_free) else sf_int%count = sf_int%count + 1 rb = 1 - r x_free = x_free * product (r) end if else call msg_bug ("Beam events: file is not open for reading") end if end associate end subroutine beam_events_generate_free @ %def beam_events_generate_free @ Set kinematics. Trivial transfer since this is a pure generator. The [[map]] flag doesn't apply. <>= procedure :: complete_kinematics => beam_events_complete_kinematics <>= subroutine beam_events_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("Beam events: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine beam_events_complete_kinematics @ %def beam_events_complete_kinematics @ Compute inverse kinematics. Trivial in this case. <>= procedure :: inverse_kinematics => beam_events_inverse_kinematics <>= subroutine beam_events_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("Beam events: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine beam_events_inverse_kinematics @ %def beam_events_inverse_kinematics @ \subsection{Beam events application} Trivial, just set the unit weight. <>= procedure :: apply => beam_events_apply <>= subroutine beam_events_apply (sf_int, scale, negative_sf, rescale, i_sub) class(beam_events_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f f = 1 call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine beam_events_apply @ %def beam_events_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_beam_events_ut.f90]]>>= <> module sf_beam_events_ut use unit_tests use sf_beam_events_uti <> <> contains <> end module sf_beam_events_ut @ %def sf_beam_events_ut @ <<[[sf_beam_events_uti.f90]]>>= <> module sf_beam_events_uti <> <> use io_units + use numeric_utils, only: pacify use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_beam_events <> <> contains <> end module sf_beam_events_uti @ %def sf_beam_events_ut @ API: driver for the unit tests below. <>= public :: sf_beam_events_test <>= subroutine sf_beam_events_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_beam_events_test @ %def sf_beam_events_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_beam_events_1, "sf_beam_events_1", & "structure function configuration", & u, results) <>= public :: sf_beam_events_1 <>= subroutine sf_beam_events_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_beam_events_1" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) call data%init (model, pdg_in, var_str (""), var_str ("beam_events.dat")) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_1" end subroutine sf_beam_events_1 @ %def sf_beam_events_1 @ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_beam_events_2, "sf_beam_events_2", & "generate event", & u, results) <>= public :: sf_beam_events_2 <>= subroutine sf_beam_events_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f integer :: i write (u, "(A)") "* Test output: sf_beam_events_2" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) call data%init (model, pdg_in, & var_str (""), var_str ("test_beam_events.dat")) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free select type (sf_int) type is (beam_events_t) write (u, "(A,1x,I0)") "count =", sf_int%count end select write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Generate more events, rewind" write (u, "(A)") select type (sf_int) type is (beam_events_t) do i = 1, 3 call sf_int%generate_free (r, rb, x_free) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,1x,I0)") "count =", sf_int%count end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_2" end subroutine sf_beam_events_2 @ %def sf_beam_events_2 @ \subsubsection{Check the file handle registry} Open and close some files, checking the registry contents. <>= call test (sf_beam_events_3, "sf_beam_events_3", & "check registry", & u, results) <>= public :: sf_beam_events_3 <>= subroutine sf_beam_events_3 (u) integer, intent(in) :: u integer :: u1 write (u, "(A)") "* Test output: sf_beam_events_2" write (u, "(A)") "* Purpose: check file handle registry" write (u, "(A)") write (u, "(A)") "* Create some empty files" write (u, "(A)") u1 = free_unit () open (u1, file = "sf_beam_events_f1.tmp", action="write", status="new") close (u1) open (u1, file = "sf_beam_events_f2.tmp", action="write", status="new") close (u1) open (u1, file = "sf_beam_events_f3.tmp", action="write", status="new") close (u1) write (u, "(A)") "* Empty registry" write (u, "(A)") call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Insert three entries" write (u, "(A)") call beam_file_registry%open (var_str ("sf_beam_events_f3.tmp")) call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%open (var_str ("sf_beam_events_f1.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Open a second channel" write (u, "(A)") call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close second entry twice" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close last entry" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f3.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close remaining entry" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f1.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" open (u1, file = "sf_beam_events_f1.tmp", action="write") close (u1, status = "delete") open (u1, file = "sf_beam_events_f2.tmp", action="write") close (u1, status = "delete") open (u1, file = "sf_beam_events_f3.tmp", action="write") close (u1, status = "delete") write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_3" end subroutine sf_beam_events_3 @ %def sf_beam_events_3 @ \clearpage %------------------------------------------------------------------------ \section{Lepton collider beamstrahlung: CIRCE1} <<[[sf_circe1.f90]]>>= <> module sf_circe1 <> use kinds, only: double <> use io_units use format_defs, only: FMT_17, FMT_19 use diagnostics use physics_defs, only: ELECTRON, PHOTON use lorentz use rng_base use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use sf_mappings use sf_base use circe1, circe1_rng_t => rng_type !NODEP! <> <> <> contains <> end module sf_circe1 @ %def sf_circe1 @ \subsection{Physics} Beamstrahlung is applied before ISR. The [[CIRCE1]] implementation has a single structure function for both beams (which makes sense since it has to be switched on or off for both beams simultaneously). Nevertheless it is factorized: The functional form in the [[CIRCE1]] parameterization is defined for electrons or photons \begin{equation} f(x) = \alpha\,x^\beta\,(1-x)^\gamma \end{equation} for $x<1-\epsilon$ (resp.\ $x>\epsilon$ in the photon case). In the remaining interval, the standard form is zero, with a delta singularity at $x=1$ (resp.\ $x=0$). Equivalently, the delta part may be distributed uniformly among this interval. This latter form is implemented in the [[kirke]] version of the [[CIRCE1]] subroutines, and is used here. The parameter [[circe1\_eps]] sets the peak mapping of the [[CIRCE1]] structure function. Its default value is $10^{-5}$. The other parameters are the parameterization version and revision number, the accelerator type, and the $\sqrt{s}$ value used by [[CIRCE1]]. The chattiness can also be set. Since the energy is distributed in a narrow region around unity (for electrons) or zero (for photons), it is advantageous to map the interval first. The mapping is controlled by the parameter [[circe1\_epsilon]] which is taken from the [[CIRCE1]] internal data structure. The $\sqrt{s}$ value, if not explicitly set, is taken from the process data. Note that interpolating $\sqrt{s}$ is not recommended; one should rather choose one of the distinct values known to [[CIRCE1]]. \subsection{The CIRCE1 data block} The CIRCE1 parameters are: The incoming flavors, the flags whether the photon or the lepton is the parton in the hard interaction, the flags for the generation mode (generator/mapping/no mapping), the mapping parameter $\epsilon$, $\sqrt{s}$ and several steering parameters: [[ver]], [[rev]], [[acc]], [[chat]]. In generator mode, the $x$ values are actually discarded and a random number generator is used instead. <>= public :: circe1_data_t <>= type, extends (sf_data_t) :: circe1_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(2) :: flv_in integer, dimension(2) :: pdg_in real(default), dimension(2) :: m_in = 0 logical, dimension(2) :: photon = .false. logical :: generate = .false. class(rng_factory_t), allocatable :: rng_factory real(default) :: sqrts = 0 real(default) :: eps = 0 integer :: ver = 0 integer :: rev = 0 character(6) :: acc = "?" integer :: chat = 0 logical :: with_radiation = .false. contains <> end type circe1_data_t @ %def circe1_data_t @ <>= procedure :: init => circe1_data_init <>= subroutine circe1_data_init & (data, model, pdg_in, sqrts, eps, out_photon, & ver, rev, acc, chat, with_radiation) class(circe1_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts real(default), intent(in) :: eps logical, dimension(2), intent(in) :: out_photon character(*), intent(in) :: acc integer, intent(in) :: ver, rev, chat logical, intent(in) :: with_radiation data%model => model if (any (pdg_array_get_length (pdg_in) /= 1)) then call msg_fatal ("CIRCE1: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%pdg_in = data%flv_in%get_pdg () data%m_in = data%flv_in%get_mass () data%sqrts = sqrts data%eps = eps data%photon = out_photon data%ver = ver data%rev = rev data%acc = acc data%chat = chat data%with_radiation = with_radiation call data%check () call circex (0.d0, 0.d0, dble (data%sqrts), & data%acc, data%ver, data%rev, data%chat) end subroutine circe1_data_init @ %def circe1_data_init @ Activate the generator mode. We import a RNG factory into the data type, which can then spawn RNG generator objects. <>= procedure :: set_generator_mode => circe1_data_set_generator_mode <>= subroutine circe1_data_set_generator_mode (data, rng_factory) class(circe1_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory data%generate = .true. call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine circe1_data_set_generator_mode @ %def circe1_data_set_generator_mode @ Handle error conditions. <>= procedure :: check => circe1_data_check <>= subroutine circe1_data_check (data) class(circe1_data_t), intent(in) :: data type(flavor_t) :: flv_electron, flv_photon call flv_electron%init (ELECTRON, data%model) call flv_photon%init (PHOTON, data%model) if (.not. flv_electron%is_defined () & .or. .not. flv_photon%is_defined ()) then call msg_fatal ("CIRCE1: model must contain photon and electron") end if if (any (abs (data%pdg_in) /= ELECTRON) & .or. (data%pdg_in(1) /= - data%pdg_in(2))) then call msg_fatal ("CIRCE1: applicable only for e+e- or e-e+ collisions") end if if (data%eps <= 0) then call msg_error ("CIRCE1: circe1_eps = 0: integration will & &miss x=1 peak") end if end subroutine circe1_data_check @ %def circe1_data_check @ Output <>= procedure :: write => circe1_data_write <>= subroutine circe1_data_write (data, unit, verbose) class(circe1_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u logical :: verb verb = .false.; if (present (verbose)) verb = verbose u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "CIRCE1 data:" write (u, "(3x,A,2(1x,A))") "prt_in =", & char (data%flv_in(1)%get_name ()), & char (data%flv_in(2)%get_name ()) write (u, "(3x,A,2(1x,L1))") "photon =", data%photon write (u, "(3x,A,L1)") "generate = ", data%generate write (u, "(3x,A,2(1x," // FMT_19 // "))") "m_in =", data%m_in write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", data%sqrts write (u, "(3x,A," // FMT_19 // ")") "eps = ", data%eps write (u, "(3x,A,I0)") "ver = ", data%ver write (u, "(3x,A,I0)") "rev = ", data%rev write (u, "(3x,A,A)") "acc = ", data%acc write (u, "(3x,A,I0)") "chat = ", data%chat write (u, "(3x,A,L1)") "with rad.= ", data%with_radiation if (data%generate) then if (verb) then call data%rng_factory%write (u) end if end if end subroutine circe1_data_write @ %def circe1_data_write @ Return true if this structure function is in generator mode. In that case, all parameters are free, otherwise bound. (We do not support mixed cases.) Default is: no generator. <>= procedure :: is_generator => circe1_data_is_generator <>= function circe1_data_is_generator (data) result (flag) class(circe1_data_t), intent(in) :: data logical :: flag flag = data%generate end function circe1_data_is_generator @ %def circe1_data_is_generator @ The number of parameters is two, collinear splitting for the two beams. <>= procedure :: get_n_par => circe1_data_get_n_par <>= function circe1_data_get_n_par (data) result (n) class(circe1_data_t), intent(in) :: data integer :: n n = 2 end function circe1_data_get_n_par @ %def circe1_data_get_n_par @ Return the outgoing particles PDG codes. This is either the incoming particle (if a photon is radiated), or the photon if that is the particle of the hard interaction. The latter is determined via the [[photon]] flag. There are two entries for the two beams. <>= procedure :: get_pdg_out => circe1_data_get_pdg_out <>= subroutine circe1_data_get_pdg_out (data, pdg_out) class(circe1_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n if (data%photon(i)) then pdg_out(i) = PHOTON else pdg_out(i) = data%pdg_in(i) end if end do end subroutine circe1_data_get_pdg_out @ %def circe1_data_get_pdg_out @ This variant is not inherited, it returns integers. <>= procedure :: get_pdg_int => circe1_data_get_pdg_int <>= function circe1_data_get_pdg_int (data) result (pdg) class(circe1_data_t), intent(in) :: data integer, dimension(2) :: pdg integer :: i do i = 1, 2 if (data%photon(i)) then pdg(i) = PHOTON else pdg(i) = data%pdg_in(i) end if end do end function circe1_data_get_pdg_int @ %def circe1_data_get_pdg_int @ Allocate the interaction record. <>= procedure :: allocate_sf_int => circe1_data_allocate_sf_int <>= subroutine circe1_data_allocate_sf_int (data, sf_int) class(circe1_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (circe1_t :: sf_int) end subroutine circe1_data_allocate_sf_int @ %def circe1_data_allocate_sf_int @ Return the accelerator type. <>= procedure :: get_beam_file => circe1_data_get_beam_file <>= function circe1_data_get_beam_file (data) result (file) class(circe1_data_t), intent(in) :: data type(string_t) :: file file = "CIRCE1: " // data%acc end function circe1_data_get_beam_file @ %def circe1_data_get_beam_file @ \subsection{Random Number Generator for CIRCE} The CIRCE implementation now supports a generic random-number generator object that allows for a local state as a component. To support this, we must extend the abstract type provided by CIRCE and delegate the generator call to the (also abstract) RNG used by WHIZARD. <>= type, extends (circe1_rng_t) :: rng_obj_t class(rng_t), allocatable :: rng contains procedure :: generate => rng_obj_generate end type rng_obj_t @ %def rng_obj_t <>= subroutine rng_obj_generate (rng_obj, u) class(rng_obj_t), intent(inout) :: rng_obj real(double), intent(out) :: u real(default) :: x call rng_obj%rng%generate (x) u = x end subroutine rng_obj_generate @ %def rng_obj_generate @ \subsection{The CIRCE1 object} This is a $2\to 4$ interaction, where, depending on the parameters, any two of the four outgoing particles are connected to the hard interactions, the others are radiated. Knowing that all particles are colorless, we do not have to deal with color. The flavors are sorted such that the first two particles are the incoming leptons, the next two are the radiated particles, and the last two are the partons initiating the hard interaction. CIRCE1 does not support polarized beams explicitly. For simplicity, we nevertheless carry beam polarization through to the outgoing electrons and make the photons unpolarized. In the case that no radiated particle is kept (which actually is the default), polarization is always transferred to the electrons, too. If there is a recoil photon in the event, the radiated particles are 3 and 4, respectively, and 5 and 6 are the outgoing ones (triggering the hard scattering process), while in the case of no radiation, the outgoing particles are 3 and 4, respectively. In the case of the electron being the radiated particle, helicity is not kept. <>= public :: circe1_t <>= type, extends (sf_int_t) :: circe1_t type(circe1_data_t), pointer :: data => null () real(default), dimension(2) :: x = 0 real(default), dimension(2) :: xb= 0 real(default) :: f = 0 logical, dimension(2) :: continuum = .true. logical, dimension(2) :: peak = .true. type(rng_obj_t) :: rng_obj contains <> end type circe1_t @ %def circe1_t @ Type string: has to be here, but there is no string variable on which CIRCE1 depends. Hence, a dummy routine. <>= procedure :: type_string => circe1_type_string <>= function circe1_type_string (object) result (string) class(circe1_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "CIRCE1: beamstrahlung" else string = "CIRCE1: [undefined]" end if end function circe1_type_string @ %def circe1_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => circe1_write <>= subroutine circe1_write (object, unit, testflag) class(circe1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%data%generate) call object%rng_obj%rng%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(3x,A,2(1x," // FMT_17 // "))") "x =", object%x write (u, "(3x,A,2(1x," // FMT_17 // "))") "xb=", object%xb if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A,1x," // FMT_17 // ")") "f =", object%f end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "CIRCE1 data: [undefined]" end if end subroutine circe1_write @ %def circe1_write @ <>= procedure :: init => circe1_init <>= subroutine circe1_init (sf_int, data) class(circe1_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data logical, dimension(6) :: mask_h type(quantum_numbers_mask_t), dimension(6) :: mask integer, dimension(6) :: hel_lock type(polarization_t), target :: pol1, pol2 type(quantum_numbers_t), dimension(1) :: qn_fc1, qn_fc2 type(flavor_t) :: flv_photon type(color_t) :: col0 real(default), dimension(2) :: mi2, mr2, mo2 type(quantum_numbers_t) :: qn_hel1, qn_hel2, qn_photon, qn1, qn2 type(quantum_numbers_t), dimension(6) :: qn type(polarization_iterator_t) :: it_hel1, it_hel2 hel_lock = 0 mask_h = .false. select type (data) type is (circe1_data_t) mi2 = data%m_in**2 if (data%with_radiation) then if (data%photon(1)) then hel_lock(1) = 3; hel_lock(3) = 1; mask_h(5) = .true. mr2(1) = mi2(1) mo2(1) = 0._default else hel_lock(1) = 5; hel_lock(5) = 1; mask_h(3) = .true. mr2(1) = 0._default mo2(1) = mi2(1) end if if (data%photon(2)) then hel_lock(2) = 4; hel_lock(4) = 2; mask_h(6) = .true. mr2(2) = mi2(2) mo2(2) = 0._default else hel_lock(2) = 6; hel_lock(6) = 2; mask_h(4) = .true. mr2(2) = 0._default mo2(2) = mi2(2) end if mask = quantum_numbers_mask (.false., .false., mask_h) call sf_int%base_init (mask, mi2, mr2, mo2, & hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col0%init () call qn_photon%init (flv_photon, col0) call pol1%init_generic (data%flv_in(1)) call qn_fc1(1)%init (flv = data%flv_in(1), col = col0) call pol2%init_generic (data%flv_in(2)) call qn_fc2(1)%init (flv = data%flv_in(2), col = col0) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel1 = it_hel1%get_quantum_numbers () qn1 = qn_hel1 .merge. qn_fc1(1) qn(1) = qn1 if (data%photon(1)) then qn(3) = qn1; qn(5) = qn_photon else qn(3) = qn_photon; qn(5) = qn1 end if call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel2 = it_hel2%get_quantum_numbers () qn2 = qn_hel2 .merge. qn_fc2(1) qn(2) = qn2 if (data%photon(2)) then qn(4) = qn2; qn(6) = qn_photon else qn(4) = qn_photon; qn(6) = qn2 end if call qn(3:4)%tag_radiated () call sf_int%add_state (qn) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol1%final () ! call pol2%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_radiated ([3,4]) call sf_int%set_outgoing ([5,6]) else if (data%photon(1)) then mask_h(3) = .true. mo2(1) = 0._default else hel_lock(1) = 3; hel_lock(3) = 1 mo2(1) = mi2(1) end if if (data%photon(2)) then mask_h(4) = .true. mo2(2) = 0._default else hel_lock(2) = 4; hel_lock(4) = 2 mo2(2) = mi2(2) end if mask = quantum_numbers_mask (.false., .false., mask_h) call sf_int%base_init (mask(1:4), mi2, [real(default) :: ], mo2, & hel_lock = hel_lock(1:4)) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col0%init () call qn_photon%init (flv_photon, col0) call pol1%init_generic (data%flv_in(1)) call qn_fc1(1)%init (flv = data%flv_in(1), col = col0) call pol2%init_generic (data%flv_in(2)) call qn_fc2(1)%init (flv = data%flv_in(2), col = col0) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel1 = it_hel1%get_quantum_numbers () qn1 = qn_hel1 .merge. qn_fc1(1) qn(1) = qn1 if (data%photon(1)) then qn(3) = qn_photon else qn(3) = qn1 end if call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel2 = it_hel2%get_quantum_numbers () qn2 = qn_hel2 .merge. qn_fc2(1) qn(2) = qn2 if (data%photon(2)) then qn(4) = qn_photon else qn(4) = qn2 end if call sf_int%add_state (qn(1:4)) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol1%final () ! call pol2%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) end if sf_int%status = SF_INITIAL end select if (sf_int%data%generate) then call sf_int%data%rng_factory%make (sf_int%rng_obj%rng) end if end subroutine circe1_init @ %def circe1_init @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => circe1_is_generator <>= function circe1_is_generator (sf_int) result (flag) class(circe1_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function circe1_is_generator @ %def circe1_is_generator @ Generate free parameters, if generator mode is on. Otherwise, the parameters will be discarded. <>= procedure :: generate_free => circe1_generate_free <>= subroutine circe1_generate_free (sf_int, r, rb, x_free) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free if (sf_int%data%generate) then call circe_generate (r, sf_int%data%get_pdg_int (), sf_int%rng_obj) rb = 1 - r x_free = x_free * product (r) else r = 0 rb= 1 end if end subroutine circe1_generate_free @ %def circe1_generate_free @ Generator mode: depending on the particle codes, call one of the available [[girce]] generators. Illegal particle code combinations should have been caught during data initialization. <>= subroutine circe_generate (x, pdg, rng_obj) real(default), dimension(2), intent(out) :: x integer, dimension(2), intent(in) :: pdg class(rng_obj_t), intent(inout) :: rng_obj real(double) :: xc1, xc2 select case (abs (pdg(1))) case (ELECTRON) select case (abs (pdg(2))) case (ELECTRON) call gircee (xc1, xc2, rng_obj = rng_obj) case (PHOTON) call girceg (xc1, xc2, rng_obj = rng_obj) end select case (PHOTON) select case (abs (pdg(2))) case (ELECTRON) call girceg (xc2, xc1, rng_obj = rng_obj) case (PHOTON) call gircgg (xc1, xc2, rng_obj = rng_obj) end select end select x = [xc1, xc2] end subroutine circe_generate @ %def circe_generate @ Set kinematics. The $r$ values (either from integration or from the generator call above) are copied to $x$ unchanged, and $f$ is unity. We store the $x$ values, so we can use them for the evaluation later. <>= procedure :: complete_kinematics => circe1_complete_kinematics <>= subroutine circe1_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb = rb sf_int%x = x sf_int%xb= xb f = 1 if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine circe1_complete_kinematics @ %def circe1_complete_kinematics @ Compute inverse kinematics. In generator mode, the $r$ values are meaningless, but we copy them anyway. <>= procedure :: inverse_kinematics => circe1_inverse_kinematics <>= subroutine circe1_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta r = x rb = xb sf_int%x = x sf_int%xb= xb f = 1 if (set_mom) then call sf_int%split_momenta (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine circe1_inverse_kinematics @ %def circe1_inverse_kinematics @ \subsection{CIRCE1 application} CIRCE is applied for the two beams at once. We can safely assume that no structure functions are applied before this, so the incoming particles are on-shell electrons/positrons. The scale is ignored. <>= procedure :: apply => circe1_apply <>= subroutine circe1_apply (sf_int, scale, negative_sf, rescale, i_sub) class(circe1_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default), dimension(2) :: xb real(double), dimension(2) :: xc real(double), parameter :: one = 1 associate (data => sf_int%data) xc = sf_int%x xb = sf_int%xb if (data%generate) then sf_int%f = 1 else sf_int%f = 0 if (all (sf_int%continuum)) then sf_int%f = circe (xc(1), xc(2), data%pdg_in(1), data%pdg_in(2)) end if if (sf_int%continuum(2) .and. sf_int%peak(1)) then sf_int%f = sf_int%f & + circe (one, xc(2), data%pdg_in(1), data%pdg_in(2)) & * peak (xb(1), data%eps) end if if (sf_int%continuum(1) .and. sf_int%peak(2)) then sf_int%f = sf_int%f & + circe (xc(1), one, data%pdg_in(1), data%pdg_in(2)) & * peak (xb(2), data%eps) end if if (all (sf_int%peak)) then sf_int%f = sf_int%f & + circe (one, one, data%pdg_in(1), data%pdg_in(2)) & * peak (xb(1), data%eps) * peak (xb(2), data%eps) end if end if end associate call sf_int%set_matrix_element (cmplx (sf_int%f, kind=default)) sf_int%status = SF_EVALUATED end subroutine circe1_apply @ %def circe1_apply @ This is a smeared delta peak at zero, as an endpoint singularity. We choose an exponentially decreasing function, starting at zero, with integral (from $0$ to $1$) $1-e^{-1/\epsilon}$. For small $\epsilon$, this reduces to one. <>= function peak (x, eps) result (f) real(default), intent(in) :: x, eps real(default) :: f f = exp (-x / eps) / eps end function peak @ %def peak @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_circe1_ut.f90]]>>= <> module sf_circe1_ut use unit_tests use sf_circe1_uti <> <> contains <> end module sf_circe1_ut @ %def sf_circe1_ut @ <<[[sf_circe1_uti.f90]]>>= <> module sf_circe1_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_circe1 use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_circe1_uti @ %def sf_circe1_ut @ API: driver for the unit tests below. <>= public :: sf_circe1_test <>= subroutine sf_circe1_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_circe1_test @ %def sf_circe1_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_circe1_1, "sf_circe1_1", & "structure function configuration", & u, results) <>= public :: sf_circe1_1 <>= subroutine sf_circe1_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_circe1_1" write (u, "(A)") "* Purpose: initialize and display & &CIRCE structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (circe1_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_1" end subroutine sf_circe1_1 @ %def sf_circe1_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= call test (sf_circe1_2, "sf_circe1_2", & "structure function instance", & u, results) <>= public :: sf_circe1_2 <>= subroutine sf_circe1_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 type(vector4_t), dimension(4) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_circe1_2" write (u, "(A)") "* Purpose: initialize and fill & &circe1 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (circe1_data_t :: data) select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.95,0.85." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.9_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1, 2]) call sf_int%seed_kinematics ([k1, k2]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_2" end subroutine sf_circe1_2 @ %def sf_circe1_2 @ \subsubsection{Generator mode} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe1_3, "sf_circe1_3", & "generator mode", & u, results) <>= public :: sf_circe1_3 <>= subroutine sf_circe1_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe1_3" write (u, "(A)") "* Purpose: initialize and fill & &circe1 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (circe1_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe1_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_3" end subroutine sf_circe1_3 @ %def sf_circe1_3 @ \clearpage %------------------------------------------------------------------------ \section{Lepton Collider Beamstrahlung and Photon collider: CIRCE2} <<[[sf_circe2.f90]]>>= <> module sf_circe2 <> <> use io_units use format_defs, only: FMT_19 use numeric_utils use diagnostics use os_interface use physics_defs, only: PHOTON, ELECTRON use lorentz use rng_base use selectors use pdg_arrays use model_data use flavors use colors use helicities use quantum_numbers use state_matrices use polarizations use sf_base use circe2, circe2_rng_t => rng_type !NODEP! <> <> <> contains <> end module sf_circe2 @ %def sf_circe2 @ \subsection{Physics} [[CIRCE2]] describes photon spectra Beamstrahlung is applied before ISR. The [[CIRCE2]] implementation has a single structure function for both beams (which makes sense since it has to be switched on or off for both beams simultaneously). \subsection{The CIRCE2 data block} The CIRCE2 parameters are: file and collider specification, incoming (= outgoing) particles. The luminosity is returned by [[circe2_luminosity]]. <>= public :: circe2_data_t <>= type, extends (sf_data_t) :: circe2_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(2) :: flv_in integer, dimension(2) :: pdg_in real(default) :: sqrts = 0 logical :: polarized = .false. logical :: beams_polarized = .false. class(rng_factory_t), allocatable :: rng_factory type(string_t) :: filename type(string_t) :: file type(string_t) :: design real(default) :: lumi = 0 real(default), dimension(4) :: lumi_hel_frac = 0 integer, dimension(0:4) :: h1 = [0, -1, -1, 1, 1] integer, dimension(0:4) :: h2 = [0, -1, 1,-1, 1] integer :: error = 1 contains <> end type circe2_data_t @ %def circe2_data_t <>= type(circe2_state) :: circe2_global_state @ <>= procedure :: init => circe2_data_init <>= subroutine circe2_data_init (data, os_data, model, pdg_in, & sqrts, polarized, beam_pol, file, design) class(circe2_data_t), intent(out) :: data type(os_data_t), intent(in) :: os_data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts logical, intent(in) :: polarized, beam_pol type(string_t), intent(in) :: file, design integer :: h data%model => model if (any (pdg_array_get_length (pdg_in) /= 1)) then call msg_fatal ("CIRCE2: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%pdg_in = data%flv_in%get_pdg () data%sqrts = sqrts data%polarized = polarized data%beams_polarized = beam_pol data%filename = file data%design = design call data%check_file (os_data) call circe2_load (circe2_global_state, trim (char(data%file)), & trim (char(data%design)), data%sqrts, data%error) call data%check () data%lumi = circe2_luminosity (circe2_global_state, data%pdg_in, [0, 0]) if (vanishes (data%lumi)) then call msg_fatal ("CIRCE2: luminosity vanishes for specified beams.") end if if (data%polarized) then do h = 1, 4 data%lumi_hel_frac(h) = & circe2_luminosity (circe2_global_state, data%pdg_in, & [data%h1(h), data%h2(h)]) & / data%lumi end do end if end subroutine circe2_data_init @ %def circe2_data_init @ Activate the generator mode. We import a RNG factory into the data type, which can then spawn RNG generator objects. <>= procedure :: set_generator_mode => circe2_data_set_generator_mode <>= subroutine circe2_data_set_generator_mode (data, rng_factory) class(circe2_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine circe2_data_set_generator_mode @ %def circe2_data_set_generator_mode @ Check whether the requested data file is in the system directory or in the current directory. <>= procedure :: check_file => circe2_check_file <>= subroutine circe2_check_file (data, os_data) class(circe2_data_t), intent(inout) :: data type(os_data_t), intent(in) :: os_data logical :: exist type(string_t) :: file file = data%filename if (file == "") & call msg_fatal ("CIRCE2: $circe2_file is not set") inquire (file = char (file), exist = exist) if (exist) then data%file = file else file = os_data%whizard_circe2path // "/" // data%filename inquire (file = char (file), exist = exist) if (exist) then data%file = file else call msg_fatal ("CIRCE2: data file '" // char (data%filename) & // "' not found") end if end if end subroutine circe2_check_file @ %def circe2_check_file @ Handle error conditions. <>= procedure :: check => circe2_data_check <>= subroutine circe2_data_check (data) class(circe2_data_t), intent(in) :: data type(flavor_t) :: flv_photon, flv_electron call flv_photon%init (PHOTON, data%model) if (.not. flv_photon%is_defined ()) then call msg_fatal ("CIRCE2: model must contain photon") end if call flv_electron%init (ELECTRON, data%model) if (.not. flv_electron%is_defined ()) then call msg_fatal ("CIRCE2: model must contain electron") end if if (any (abs (data%pdg_in) /= PHOTON .and. abs (data%pdg_in) /= ELECTRON)) & then call msg_fatal ("CIRCE2: applicable only for e+e- or photon collisions") end if select case (data%error) case (-1) call msg_fatal ("CIRCE2: data file not found.") case (-2) call msg_fatal ("CIRCE2: beam setup does not match data file.") case (-3) call msg_fatal ("CIRCE2: invalid format of data file.") case (-4) call msg_fatal ("CIRCE2: data file too large.") end select end subroutine circe2_data_check @ %def circe2_data_check @ Output <>= procedure :: write => circe2_data_write <>= subroutine circe2_data_write (data, unit, verbose) class(circe2_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, h logical :: verb verb = .false.; if (present (verbose)) verb = verbose u = given_output_unit (unit) write (u, "(1x,A)") "CIRCE2 data:" write (u, "(3x,A,A)") "file = ", char(data%filename) write (u, "(3x,A,A)") "design = ", char(data%design) write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", data%sqrts write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,L1)") "polarized = ", data%polarized write (u, "(3x,A,L1)") "beams pol. = ", data%beams_polarized write (u, "(3x,A," // FMT_19 // ")") "luminosity = ", data%lumi if (data%polarized) then do h = 1, 4 write (u, "(6x,'(',I2,1x,I2,')',1x,'=',1x)", advance="no") & data%h1(h), data%h2(h) write (u, "(6x, " // FMT_19 // ")") data%lumi_hel_frac(h) end do end if if (verb) then call data%rng_factory%write (u) end if end subroutine circe2_data_write @ %def circe2_data_write @ This is always in generator mode. <>= procedure :: is_generator => circe2_data_is_generator <>= function circe2_data_is_generator (data) result (flag) class(circe2_data_t), intent(in) :: data logical :: flag flag = .true. end function circe2_data_is_generator @ %def circe2_data_is_generator @ The number of parameters is two, collinear splitting for the two beams. <>= procedure :: get_n_par => circe2_data_get_n_par <>= function circe2_data_get_n_par (data) result (n) class(circe2_data_t), intent(in) :: data integer :: n n = 2 end function circe2_data_get_n_par @ %def circe2_data_get_n_par @ Return the outgoing particles PDG codes. They are equal to the incoming ones. <>= procedure :: get_pdg_out => circe2_data_get_pdg_out <>= subroutine circe2_data_get_pdg_out (data, pdg_out) class(circe2_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%pdg_in(i) end do end subroutine circe2_data_get_pdg_out @ %def circe2_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => circe2_data_allocate_sf_int <>= subroutine circe2_data_allocate_sf_int (data, sf_int) class(circe2_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (circe2_t :: sf_int) end subroutine circe2_data_allocate_sf_int @ %def circe2_data_allocate_sf_int @ Return the beam file. <>= procedure :: get_beam_file => circe2_data_get_beam_file <>= function circe2_data_get_beam_file (data) result (file) class(circe2_data_t), intent(in) :: data type(string_t) :: file file = "CIRCE2: " // data%filename end function circe2_data_get_beam_file @ %def circe2_data_get_beam_file @ \subsection{Random Number Generator for CIRCE} The CIRCE implementation now supports a generic random-number generator object that allows for a local state as a component. To support this, we must extend the abstract type provided by CIRCE and delegate the generator call to the (also abstract) RNG used by WHIZARD. <>= type, extends (circe2_rng_t) :: rng_obj_t class(rng_t), allocatable :: rng contains procedure :: generate => rng_obj_generate end type rng_obj_t @ %def rng_obj_t <>= subroutine rng_obj_generate (rng_obj, u) class(rng_obj_t), intent(inout) :: rng_obj real(default), intent(out) :: u real(default) :: x call rng_obj%rng%generate (x) u = x end subroutine rng_obj_generate @ %def rng_obj_generate @ \subsection{The CIRCE2 object} For CIRCE2 spectra it does not make sense to describe the state matrix as a radiation interaction, even if photons originate from laser backscattering. Instead, it is a $2\to 2$ interaction where the incoming particles are identical to the outgoing ones. The current implementation of CIRCE2 does support polarization and classical correlations, but no entanglement, so the density matrix of the outgoing particles is diagonal. The incoming particles are unpolarized (user-defined polarization for beams is meaningless, since polarization is described by the data file). The outgoing particles are polarized or polarization-averaged, depending on user request. When assigning matrix elements, we scan the previously initialized state matrix. For each entry, we extract helicity and call the structure function. In the unpolarized case, the helicity is undefined and replaced by value zero. In the polarized case, there are four entries. If the generator is used, only one entry is nonzero in each call. Which one, is determined by comparing with a previously (randomly, distributed by relative luminosity) selected pair of helicities. <>= public :: circe2_t <>= type, extends (sf_int_t) :: circe2_t type(circe2_data_t), pointer :: data => null () type(rng_obj_t) :: rng_obj type(selector_t) :: selector integer :: h_sel = 0 contains <> end type circe2_t @ %def circe2_t @ Type string: show file and design of [[CIRCE2]] structure function. <>= procedure :: type_string => circe2_type_string <>= function circe2_type_string (object) result (string) class(circe2_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "CIRCE2: " // object%data%design else string = "CIRCE2: [undefined]" end if end function circe2_type_string @ %def circe2_type_string @ @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => circe2_write <>= subroutine circe2_write (object, unit, testflag) class(circe2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "CIRCE2 data: [undefined]" end if end subroutine circe2_write @ %def circe2_write @ <>= procedure :: init => circe2_init <>= subroutine circe2_init (sf_int, data) class(circe2_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data logical, dimension(4) :: mask_h real(default), dimension(2) :: m2_array real(default), dimension(0) :: null_array type(quantum_numbers_mask_t), dimension(4) :: mask type(quantum_numbers_t), dimension(4) :: qn type(helicity_t) :: hel type(color_t) :: col0 integer :: h select type (data) type is (circe2_data_t) if (data%polarized .and. data%beams_polarized) then call msg_fatal ("CIRCE2: Beam polarization can't be set & &for polarized data file") else if (data%beams_polarized) then call msg_warning ("CIRCE2: User-defined beam polarization set & &for unpolarized CIRCE2 data file") end if mask_h(1:2) = .not. data%beams_polarized mask_h(3:4) = .not. (data%polarized .or. data%beams_polarized) mask = quantum_numbers_mask (.false., .false., mask_h) m2_array(:) = (data%flv_in(:)%get_mass ())**2 call sf_int%base_init (mask, m2_array, null_array, m2_array) sf_int%data => data if (data%polarized) then if (vanishes (sum (data%lumi_hel_frac)) .or. & any (data%lumi_hel_frac < 0)) then call msg_fatal ("CIRCE2: Helicity-dependent lumi " & // "fractions all vanish or", & [var_str ("are negative: Please inspect the " & // "CIRCE2 file or "), & var_str ("switch off the polarized" // & " option for CIRCE2.")]) else call sf_int%selector%init (data%lumi_hel_frac) end if end if call col0%init () if (data%beams_polarized) then do h = 1, 4 call hel%init (data%h1(h)) call qn(1)%init & (flv = data%flv_in(1), col = col0, hel = hel) call qn(3)%init & (flv = data%flv_in(1), col = col0, hel = hel) call hel%init (data%h2(h)) call qn(2)%init & (flv = data%flv_in(2), col = col0, hel = hel) call qn(4)%init & (flv = data%flv_in(2), col = col0, hel = hel) call sf_int%add_state (qn) end do else if (data%polarized) then call qn(1)%init (flv = data%flv_in(1), col = col0) call qn(2)%init (flv = data%flv_in(2), col = col0) do h = 1, 4 call hel%init (data%h1(h)) call qn(3)%init & (flv = data%flv_in(1), col = col0, hel = hel) call hel%init (data%h2(h)) call qn(4)%init & (flv = data%flv_in(2), col = col0, hel = hel) call sf_int%add_state (qn) end do else call qn(1)%init (flv = data%flv_in(1), col = col0) call qn(2)%init (flv = data%flv_in(2), col = col0) call qn(3)%init (flv = data%flv_in(1), col = col0) call qn(4)%init (flv = data%flv_in(2), col = col0) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%data%rng_factory%make (sf_int%rng_obj%rng) sf_int%status = SF_INITIAL end select end subroutine circe2_init @ %def circe2_init @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => circe2_is_generator <>= function circe2_is_generator (sf_int) result (flag) class(circe2_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function circe2_is_generator @ %def circe2_is_generator @ Generate free parameters. We first select a helicity, which we have to store, then generate $x$ values for that helicity. <>= procedure :: generate_free => circe2_generate_whizard_free <>= subroutine circe2_generate_whizard_free (sf_int, r, rb, x_free) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free integer :: h_sel if (sf_int%data%polarized) then call sf_int%selector%generate (sf_int%rng_obj%rng, h_sel) else h_sel = 0 end if sf_int%h_sel = h_sel call circe2_generate_whizard (r, sf_int%data%pdg_in, & [sf_int%data%h1(h_sel), sf_int%data%h2(h_sel)], & sf_int%rng_obj) rb = 1 - r x_free = x_free * product (r) end subroutine circe2_generate_whizard_free @ %def circe2_generate_whizard_free @ Generator mode: call the CIRCE2 generator for the given particles and helicities. (For unpolarized generation, helicities are zero.) <>= subroutine circe2_generate_whizard (x, pdg, hel, rng_obj) real(default), dimension(2), intent(out) :: x integer, dimension(2), intent(in) :: pdg integer, dimension(2), intent(in) :: hel class(rng_obj_t), intent(inout) :: rng_obj call circe2_generate (circe2_global_state, rng_obj, x, pdg, hel) end subroutine circe2_generate_whizard @ %def circe2_generate_whizard @ Set kinematics. Trivial here. <>= procedure :: complete_kinematics => circe2_complete_kinematics <>= subroutine circe2_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("CIRCE2: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine circe2_complete_kinematics @ %def circe2_complete_kinematics @ Compute inverse kinematics. <>= procedure :: inverse_kinematics => circe2_inverse_kinematics <>= subroutine circe2_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("CIRCE2: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine circe2_inverse_kinematics @ %def circe2_inverse_kinematics @ \subsection{CIRCE2 application} This function works on both beams. In polarized mode, we set only the selected helicity. In unpolarized mode, the interaction has only one entry, and the factor is unity. <>= procedure :: apply => circe2_apply <>= subroutine circe2_apply (sf_int, scale, negative_sf, rescale, i_sub) class(circe2_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub complex(default) :: f associate (data => sf_int%data) f = 1 if (data%beams_polarized) then call sf_int%set_matrix_element (f) else if (data%polarized) then call sf_int%set_matrix_element (sf_int%h_sel, f) else call sf_int%set_matrix_element (1, f) end if end associate sf_int%status = SF_EVALUATED end subroutine circe2_apply @ %def circe2_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_circe2_ut.f90]]>>= <> module sf_circe2_ut use unit_tests use sf_circe2_uti <> <> contains <> end module sf_circe2_ut @ %def sf_circe2_ut @ <<[[sf_circe2_uti.f90]]>>= <> module sf_circe2_uti <> <> use os_interface use physics_defs, only: PHOTON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_circe2 use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_circe2_uti @ %def sf_circe2_ut @ API: driver for the unit tests below. <>= public :: sf_circe2_test <>= subroutine sf_circe2_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_circe2_test @ %def sf_circe2_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_circe2_1, "sf_circe2_1", & "structure function configuration", & u, results) <>= public :: sf_circe2_1 <>= subroutine sf_circe2_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data class(rng_factory_t), allocatable :: rng_factory write (u, "(A)") "* Test output: sf_circe2_1" write (u, "(A)") "* Purpose: initialize and display & &CIRCE structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call os_data%init () call model%init_qed_test () pdg_in(1) = PHOTON pdg_in(2) = PHOTON allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) write (u, "(A)") write (u, "(A)") "* Initialize (unpolarized)" write (u, "(A)") select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .false., & beam_pol = .false., & file = var_str ("teslagg_500_polavg.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select call data%write (u, verbose = .true.) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 write (u, "(A)") write (u, "(A)") "* Initialize (polarized)" write (u, "(A)") allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .true., & beam_pol = .false., & file = var_str ("teslagg_500.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select call data%write (u, verbose = .true.) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_1" end subroutine sf_circe2_1 @ %def sf_circe2_1 @ \subsubsection{Generator mode, unpolarized} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe2_2, "sf_circe2_2", & "generator, unpolarized", & u, results) <>= public :: sf_circe2_2 <>= subroutine sf_circe2_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe2_2" write (u, "(A)") "* Purpose: initialize and fill & &circe2 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_qed_test () call flv(1)%init (PHOTON, model) call flv(2)%init (PHOTON, model) pdg_in(1) = PHOTON pdg_in(2) = PHOTON call reset_interaction_counter () allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .false., & beam_pol = .false., & file = var_str ("teslagg_500_polavg.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe2_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_2" end subroutine sf_circe2_2 @ %def sf_circe2_2 @ \subsubsection{Generator mode, polarized} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe2_3, "sf_circe2_3", & "generator, polarized", & u, results) <>= public :: sf_circe2_3 <>= subroutine sf_circe2_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe2_3" write (u, "(A)") "* Purpose: initialize and fill & &circe2 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_qed_test () call flv(1)%init (PHOTON, model) call flv(2)%init (PHOTON, model) pdg_in(1) = PHOTON pdg_in(2) = PHOTON call reset_interaction_counter () allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .true., & beam_pol = .false., & file = var_str ("teslagg_500.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe2_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_3" end subroutine sf_circe2_3 @ %def sf_circe2_3 @ \clearpage %------------------------------------------------------------------------ \section{HOPPET interface} Interface to the HOPPET wrapper necessary to perform the LO vs. NLO matching of processes containing an initial b quark. <<[[hoppet_interface.f90]]>>= <> module hoppet_interface use lhapdf !NODEP! <> public :: hoppet_init, hoppet_eval contains subroutine hoppet_init (pdf_builtin, pdf, pdf_id) logical, intent(in) :: pdf_builtin type(lhapdf_pdf_t), intent(inout), optional :: pdf integer, intent(in), optional :: pdf_id external InitForWhizard call InitForWhizard (pdf_builtin, pdf, pdf_id) end subroutine hoppet_init subroutine hoppet_eval (x, q, f) double precision, intent(in) :: x, q double precision, intent(out) :: f(-6:6) external EvalForWhizard call EvalForWhizard (x, q, f) end subroutine hoppet_eval end module hoppet_interface @ %def hoppet_interface @ \clearpage %------------------------------------------------------------------------ \section{Builtin PDF sets} For convenience in order not to depend on the external package LHAPDF, we ship some PDFs with WHIZARD. @ \subsection{The module} <<[[sf_pdf_builtin.f90]]>>= <> module sf_pdf_builtin <> use kinds, only: double <> use io_units use format_defs, only: FMT_17 use diagnostics use os_interface use physics_defs, only: PROTON, PHOTON, GLUON use physics_defs, only: HADRON_REMNANT_SINGLET use physics_defs, only: HADRON_REMNANT_TRIPLET use physics_defs, only: HADRON_REMNANT_OCTET use sm_qcd use lorentz use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use sf_base use pdf_builtin !NODEP! use hoppet_interface <> <> <> <> contains <> end module sf_pdf_builtin @ %def sf_pdf_builtin @ \subsection{Codes for default PDF sets} <>= character(*), parameter :: PDF_BUILTIN_DEFAULT_PROTON = "CTEQ6L" ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PION = "NONE" ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PHOTON = "MRST2004QEDp" @ %def PDF_BUILTIN_DEFAULT_SET @ \subsection{The PDF builtin data block} The data block holds the incoming flavor (which has to be proton, pion, or photon), the corresponding pointer to the global access data (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the bounds as returned by LHAPDF for the specified set, and a mask that determines which partons will be actually in use. <>= public :: pdf_builtin_data_t <>= type, extends (sf_data_t) :: pdf_builtin_data_t private integer :: id = -1 type (string_t) :: name class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in logical :: invert logical :: has_photon logical :: photon logical, dimension(-6:6) :: mask logical :: mask_photon logical :: hoppet_b_matching = .false. contains <> end type pdf_builtin_data_t @ %def pdf_builtin_data_t @ Generate PDF data and initialize the requested set. Pion and photon PDFs are disabled at the moment until we ship appropiate structure functions. needed. <>= procedure :: init => pdf_builtin_data_init <>= subroutine pdf_builtin_data_init (data, & model, pdg_in, name, path, hoppet_b_matching) class(pdf_builtin_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in type(string_t), intent(in) :: name type(string_t), intent(in) :: path logical, intent(in), optional :: hoppet_b_matching data%model => model if (pdg_array_get_length (pdg_in) /= 1) & call msg_fatal ("PDF: incoming particle must be unique") call data%flv_in%init (pdg_array_get (pdg_in, 1), model) data%mask = .true. data%mask_photon = .true. select case (pdg_array_get (pdg_in, 1)) case (PROTON) data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON) data%invert = .false. data%photon = .false. case (-PROTON) data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON) data%invert = .true. data%photon = .false. ! case (PIPLUS) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PION) ! data%invert = .false. ! data%photon = .false. ! case (-PIPLUS) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PION) ! data%invert = .true. ! data%photon = .false. ! case (PHOTON) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PHOTON) ! data%invert = .false. ! data%photon = .true. case default call msg_fatal ("PDF: " & // "incoming particle must either proton or antiproton.") return end select data%name = name data%id = pdf_get_id (data%name) if (data%id < 0) call msg_fatal ("unknown PDF set " // char (data%name)) data%has_photon = pdf_provides_photon (data%id) if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching call pdf_init (data%id, path) if (data%hoppet_b_matching) call hoppet_init (.true., pdf_id = data%id) end subroutine pdf_builtin_data_init @ %def pdf_builtin_data_init @ Enable/disable partons explicitly. If a mask entry is true, applying the PDF will generate the corresponding flavor on output. <>= procedure :: set_mask => pdf_builtin_data_set_mask <>= subroutine pdf_builtin_data_set_mask (data, mask) class(pdf_builtin_data_t), intent(inout) :: data logical, dimension(-6:6), intent(in) :: mask data%mask = mask end subroutine pdf_builtin_data_set_mask @ %def pdf_builtin_data_set_mask @ Output. <>= procedure :: write => pdf_builtin_data_write <>= subroutine pdf_builtin_data_write (data, unit, verbose) class(pdf_builtin_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "PDF builtin data:" if (data%id < 0) then write (u, "(3x,A)") "[undefined]" return end if write (u, "(3x,A)", advance="no") "flavor = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A,A)") "name = ", char (data%name) write (u, "(3x,A,L1)") "invert = ", data%invert write (u, "(3x,A,L1)") "has photon = ", data%has_photon write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") & "mask =", & data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6) write (u, "(3x,A,L1)") "photon mask = ", data%mask_photon write (u, "(3x,A,L1)") "hoppet_b = ", data%hoppet_b_matching end subroutine pdf_builtin_data_write @ %def pdf_builtin_data_write @ The number of parameters is one. We do not generate transverse momentum. <>= procedure :: get_n_par => pdf_builtin_data_get_n_par <>= function pdf_builtin_data_get_n_par (data) result (n) class(pdf_builtin_data_t), intent(in) :: data integer :: n n = 1 end function pdf_builtin_data_get_n_par @ %def pdf_builtin_data_get_n_par @ Return the outgoing particle PDG codes. This is based on the mask. <>= procedure :: get_pdg_out => pdf_builtin_data_get_pdg_out <>= subroutine pdf_builtin_data_get_pdg_out (data, pdg_out) class(pdf_builtin_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: n, np, i n = count (data%mask) np = 0; if (data%has_photon .and. data%mask_photon) np = 1 allocate (pdg1 (n + np)) pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask) if (np == 1) pdg1(n+np) = PHOTON pdg_out(1) = pdg1 end subroutine pdf_builtin_data_get_pdg_out @ %def pdf_builtin_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => pdf_builtin_data_allocate_sf_int <>= subroutine pdf_builtin_data_allocate_sf_int (data, sf_int) class(pdf_builtin_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (pdf_builtin_t :: sf_int) end subroutine pdf_builtin_data_allocate_sf_int @ %def pdf_builtin_data_allocate_sf_int @ Return the numerical PDF set index. <>= procedure :: get_pdf_set => pdf_builtin_data_get_pdf_set <>= elemental function pdf_builtin_data_get_pdf_set (data) result (pdf_set) class(pdf_builtin_data_t), intent(in) :: data integer :: pdf_set pdf_set = data%id end function pdf_builtin_data_get_pdf_set @ %def pdf_builtin_data_get_pdf_set @ \subsection{The PDF object} The PDF $1\to 2$ interaction which describes the splitting of an (anti)proton into a parton and a beam remnant. We stay in the strict forward-splitting limit, but allow some invariant mass for the beam remnant such that the outgoing parton is exactly massless. For a real event, we would replace this by a parton cascade, where the outgoing partons have virtuality as dictated by parton-shower kinematics, and transverse momentum is generated. The PDF application is a $1\to 2$ splitting process, where the particles are ordered as (hadron, remnant, parton). Polarization is ignored completely. The beam particle is colorless, while partons and beam remnant carry color. The remnant gets a special flavor code. <>= public :: pdf_builtin_t <>= type, extends (sf_int_t) :: pdf_builtin_t type(pdf_builtin_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: q = 0 contains <> end type pdf_builtin_t @ %def pdf_builtin_t @ Type string: display the chosen PDF set. <>= procedure :: type_string => pdf_builtin_type_string <>= function pdf_builtin_type_string (object) result (string) class(pdf_builtin_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "PDF builtin: " // object%data%name else string = "PDF builtin: [undefined]" end if end function pdf_builtin_type_string @ %def pdf_builtin_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => pdf_builtin_write <>= subroutine pdf_builtin_write (object, unit, testflag) class(pdf_builtin_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "PDF builtin data: [undefined]" end if end subroutine pdf_builtin_write @ %def pdf_builtin_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => pdf_builtin_init <>= subroutine pdf_builtin_init (sf_int, data) class(pdf_builtin_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(flavor_t) :: flv, flv_remnant type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn integer :: i select type (data) type is (pdf_builtin_data_t) mask = quantum_numbers_mask (.false., .false., .true.) call col0%init () call sf_int%base_init (mask, [0._default], [0._default], [0._default]) sf_int%data => data do i = -6, 6 if (data%mask(i)) then call qn(1)%init (data%flv_in, col = col0) if (i == 0) then call flv%init (GLUON, data%model) call flv_remnant%init (HADRON_REMNANT_OCTET, data%model) else call flv%init (i, data%model) call flv_remnant%init & (sign (HADRON_REMNANT_TRIPLET, -i), data%model) end if call qn(2)%init ( & flv = flv_remnant, col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init ( & flv = flv, col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if end do if (data%has_photon .and. data%mask_photon) then call flv%init (PHOTON, data%model) call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model) call qn(2)%init (flv = flv_remnant, & col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init (flv = flv, & col = color_from_flavor (flv, 1, reverse = .true.)) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine pdf_builtin_init @ %def pdf_builtin_init @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => pdf_builtin_complete_kinematics <>= subroutine pdf_builtin_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("PDF builtin: map flag not supported") else x(1) = r(1) xb(1)= rb(1) f = 1 end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 f = 0 end select end subroutine pdf_builtin_complete_kinematics @ %def pdf_builtin_complete_kinematics @ Overriding the default method: we compute the [[x]] value from the momentum configuration. In this specific case, we also set the internally stored $x$ value, so it can be used in the following routine. <>= procedure :: recover_x => pdf_builtin_recover_x <>= subroutine pdf_builtin_recover_x (sf_int, x, xb, x_free) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) end subroutine pdf_builtin_recover_x @ %def sf_pdf_builtin_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => pdf_builtin_inverse_kinematics <>= subroutine pdf_builtin_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("PDF builtin: map flag not supported") else r(1) = x(1) rb(1)= xb(1) f = 1 end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine pdf_builtin_inverse_kinematics @ %def pdf_builtin_inverse_kinematics @ \subsection{Structure function} Once the scale is also known, we can actually call the PDF and set the values. Contrary to LHAPDF, the wrapper already takes care of adjusting to the $x$ and $Q$ bounds. Account for the Jacobian. The parameter [[negative_sf]] is necessary to determine if we allow for negative PDF values. The class [[rescale]] gives rescaling prescription for NLO convolution of the structure function in combination with [[i_sub]]. <>= procedure :: apply => pdf_builtin_apply <>= subroutine pdf_builtin_apply (sf_int, scale, negative_sf, rescale, i_sub) class(pdf_builtin_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default), dimension(-6:6) :: ff real(double), dimension(-6:6) :: ff_dbl real(default) :: x, fph real(double) :: xx, qq complex(default), dimension(:), allocatable :: fc integer :: i, j_sub, i_sub_opt logical :: negative_sf_opt i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf associate (data => sf_int%data) sf_int%q = scale x = sf_int%x if (present (rescale)) call rescale%apply (x) if (debug2_active (D_BEAMS)) then call msg_debug2 (D_BEAMS, "pdf_builtin_apply") call msg_debug2 (D_BEAMS, "rescale: ", present(rescale)) call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt) call msg_debug2 (D_BEAMS, "x: ", x) end if xx = x qq = scale if (data%invert) then if (data%has_photon) then call pdf_evolve (data%id, x, scale, ff(6:-6:-1), fph) else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff_dbl(6:-6:-1)) ff = ff_dbl else call pdf_evolve (data%id, x, scale, ff(6:-6:-1)) end if end if else if (data%has_photon) then call pdf_evolve (data%id, x, scale, ff, fph) else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff_dbl) ff = ff_dbl else call pdf_evolve (data%id, x, scale, ff) end if end if end if if (data%has_photon) then allocate (fc (count ([data%mask, data%mask_photon]))) if (negative_sf_opt) then fc = pack ([ff, fph], [data%mask, data%mask_photon]) else fc = max( pack ([ff, fph], [data%mask, data%mask_photon]), 0._default) end if else allocate (fc (count (data%mask))) if (negative_sf_opt) then fc = pack (ff, data%mask) else fc = max( pack (ff, data%mask), 0._default) end if end if end associate if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc) call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))]) sf_int%status = SF_EVALUATED end subroutine pdf_builtin_apply @ %def pdf_builtin_apply @ \subsection{Strong Coupling} Since the PDF codes provide a function for computing the running $\alpha_s$ value, we make this available as an implementation of the abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation. <>= public :: alpha_qcd_pdf_builtin_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_pdf_builtin_t type(string_t) :: pdfset_name integer :: pdfset_id = -1 contains <> end type alpha_qcd_pdf_builtin_t @ %def alpha_qcd_pdf_builtin_t @ Output. <>= procedure :: write => alpha_qcd_pdf_builtin_write <>= subroutine alpha_qcd_pdf_builtin_write (object, unit) class(alpha_qcd_pdf_builtin_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A)") "QCD parameters (pdf_builtin):" write (u, "(5x,A,A)") "PDF set = ", char (object%pdfset_name) write (u, "(5x,A,I0)") "PDF ID = ", object%pdfset_id end subroutine alpha_qcd_pdf_builtin_write @ %def alpha_qcd_pdf_builtin_write @ Calculation: the numeric ID selects the correct PDF set, which must be properly initialized. <>= procedure :: get => alpha_qcd_pdf_builtin_get <>= function alpha_qcd_pdf_builtin_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_pdf_builtin_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = pdf_alphas (alpha_qcd%pdfset_id, scale) end function alpha_qcd_pdf_builtin_get @ %def alpha_qcd_pdf_builtin_get @ Initialization. We need to access the global initialization status. <>= procedure :: init => alpha_qcd_pdf_builtin_init <>= subroutine alpha_qcd_pdf_builtin_init (alpha_qcd, name, path) class(alpha_qcd_pdf_builtin_t), intent(out) :: alpha_qcd type(string_t), intent(in) :: name type(string_t), intent(in) :: path alpha_qcd%pdfset_name = name alpha_qcd%pdfset_id = pdf_get_id (name) if (alpha_qcd%pdfset_id < 0) & call msg_fatal ("QCD parameter initialization: PDF set " & // char (name) // " is unknown") call pdf_init (alpha_qcd%pdfset_id, path) end subroutine alpha_qcd_pdf_builtin_init @ %def alpha_qcd_pdf_builtin_init @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_pdf_builtin_ut.f90]]>>= <> module sf_pdf_builtin_ut use unit_tests use sf_pdf_builtin_uti <> <> contains <> end module sf_pdf_builtin_ut @ %def sf_pdf_builtin_ut @ <<[[sf_pdf_builtin_uti.f90]]>>= <> module sf_pdf_builtin_uti <> <> use os_interface use physics_defs, only: PROTON use sm_qcd use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_base use sf_pdf_builtin <> <> contains <> end module sf_pdf_builtin_uti @ %def sf_pdf_builtin_ut @ API: driver for the unit tests below. <>= public :: sf_pdf_builtin_test <>= subroutine sf_pdf_builtin_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_pdf_builtin_test @ %def sf_pdf_builtin_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_pdf_builtin_1, "sf_pdf_builtin_1", & "structure function configuration", & u, results) <>= public :: sf_pdf_builtin_1 <>= subroutine sf_pdf_builtin_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data type(string_t) :: name write (u, "(A)") "* Test output: sf_pdf_builtin_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call os_data%init () call model%init_sm_test () pdg_in = PROTON allocate (pdf_builtin_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") name = "CTEQ6L" select type (data) type is (pdf_builtin_data_t) call data%init (model, pdg_in, name, & os_data%pdf_builtin_datapath) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_1" end subroutine sf_pdf_builtin_1 @ %def sf_pdf_builtin_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= call test (sf_pdf_builtin_2, "sf_pdf_builtin_2", & "structure function instance", & u, results) <>= public :: sf_pdf_builtin_2 <>= subroutine sf_pdf_builtin_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(string_t) :: name type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_pdf_builtin_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_sm_test () call flv%init (PROTON, model) pdg_in = PROTON call reset_interaction_counter () name = "CTEQ6L" allocate (pdf_builtin_data_t :: data) select type (data) type is (pdf_builtin_data_t) call data%init (model, pdg_in, name, & os_data%pdf_builtin_datapath) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100 GeV" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_2" end subroutine sf_pdf_builtin_2 @ %def sf_pdf_builtin_2 @ \subsubsection{Strong Coupling} Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract type. <>= call test (sf_pdf_builtin_3, "sf_pdf_builtin_3", & "running alpha_s", & u, results) <>= public :: sf_pdf_builtin_3 <>= subroutine sf_pdf_builtin_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(qcd_t) :: qcd type(string_t) :: name write (u, "(A)") "* Test output: sf_pdf_builtin_3" write (u, "(A)") "* Purpose: initialize and evaluate alpha_s" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () name = "CTEQ6L" write (u, "(A)") "* Initialize qcd object" write (u, "(A)") allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha) select type (alpha => qcd%alpha) type is (alpha_qcd_pdf_builtin_t) call alpha%init (name, os_data%pdf_builtin_datapath) end select call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100" write (u, "(A)") write (u, "(1x,A,F8.5)") "alpha = ", qcd%alpha%get (100._default) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_3" end subroutine sf_pdf_builtin_3 @ %def sf_pdf_builtin_3 @ \clearpage %------------------------------------------------------------------------ \section{LHAPDF} Parton distribution functions (PDFs) are available via an interface to the LHAPDF standard library. @ \subsection{The module} <<[[sf_lhapdf.f90]]>>= <> module sf_lhapdf <> <> use format_defs, only: FMT_17, FMT_19 use io_units use system_dependencies, only: LHAPDF_PDFSETS_PATH use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use diagnostics use physics_defs, only: PROTON, PHOTON, PIPLUS, GLUON use physics_defs, only: HADRON_REMNANT_SINGLET use physics_defs, only: HADRON_REMNANT_TRIPLET use physics_defs, only: HADRON_REMNANT_OCTET use lorentz use sm_qcd use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use sf_base use lhapdf !NODEP! use hoppet_interface <> <> <> <> <> <> contains <> end module sf_lhapdf @ %def sf_lhapdf @ \subsection{Codes for default PDF sets} The default PDF for protons set is chosen to be CTEQ6ll (LO fit with LO $\alpha_s$). <>= character(*), parameter :: LHAPDF5_DEFAULT_PROTON = "cteq6ll.LHpdf" character(*), parameter :: LHAPDF5_DEFAULT_PION = "ABFKWPI.LHgrid" character(*), parameter :: LHAPDF5_DEFAULT_PHOTON = "GSG960.LHgrid" character(*), parameter :: LHAPDF6_DEFAULT_PROTON = "CT10" @ %def LHAPDF5_DEFAULT_PROTON LHAPDF5_DEFAULT_PION @ %def LHAPDF5_DEFAULT_PHOTON LHAPDF6_DEFAULT_PROTON @ \subsection{LHAPDF library interface} Here we specify explicit interfaces for all LHAPDF routines that we use below. <>= interface subroutine InitPDFsetM (set, file) integer, intent(in) :: set character(*), intent(in) :: file end subroutine InitPDFsetM end interface @ %def InitPDFsetM <>= interface subroutine InitPDFM (set, mem) integer, intent(in) :: set, mem end subroutine InitPDFM end interface @ %def InitPDFM <>= interface subroutine numberPDFM (set, n_members) integer, intent(in) :: set integer, intent(out) :: n_members end subroutine numberPDFM end interface @ %def numberPDFM <>= interface subroutine evolvePDFM (set, x, q, ff) integer, intent(in) :: set double precision, intent(in) :: x, q double precision, dimension(-6:6), intent(out) :: ff end subroutine evolvePDFM end interface @ %def evolvePDFM <>= interface subroutine evolvePDFphotonM (set, x, q, ff, fphot) integer, intent(in) :: set double precision, intent(in) :: x, q double precision, dimension(-6:6), intent(out) :: ff double precision, intent(out) :: fphot end subroutine evolvePDFphotonM end interface @ %def evolvePDFphotonM <>= interface subroutine evolvePDFpM (set, x, q, s, scheme, ff) integer, intent(in) :: set double precision, intent(in) :: x, q, s integer, intent(in) :: scheme double precision, dimension(-6:6), intent(out) :: ff end subroutine evolvePDFpM end interface @ %def evolvePDFpM <>= interface subroutine GetXminM (set, mem, xmin) integer, intent(in) :: set, mem double precision, intent(out) :: xmin end subroutine GetXminM end interface @ %def GetXminM <>= interface subroutine GetXmaxM (set, mem, xmax) integer, intent(in) :: set, mem double precision, intent(out) :: xmax end subroutine GetXmaxM end interface @ %def GetXmaxM <>= interface subroutine GetQ2minM (set, mem, q2min) integer, intent(in) :: set, mem double precision, intent(out) :: q2min end subroutine GetQ2minM end interface @ %def GetQ2minM <>= interface subroutine GetQ2maxM (set, mem, q2max) integer, intent(in) :: set, mem double precision, intent(out) :: q2max end subroutine GetQ2maxM end interface @ %def GetQ2maxM <>= interface function has_photon () result(flag) logical :: flag end function has_photon end interface @ %def has_photon @ \subsection{The LHAPDF status} This type holds the initialization status of the LHAPDF system. Entry 1 is for proton PDFs, entry 2 for pion PDFs, entry 3 for photon PDFs. Since it is connected to the external LHAPDF library, this is a truly global object. We implement it as a a private module variable. To access it from elsewhere, the caller has to create and initialize an object of type [[lhapdf_status_t]], which acts as a proxy. <>= type :: lhapdf_global_status_t private logical, dimension(3) :: initialized = .false. end type lhapdf_global_status_t @ %def lhapdf_global_status_t <>= type(lhapdf_global_status_t), save :: lhapdf_global_status @ %def lhapdf_global_status <>= function lhapdf_global_status_is_initialized (set) result (flag) logical :: flag integer, intent(in), optional :: set if (present (set)) then select case (set) case (1:3); flag = lhapdf_global_status%initialized(set) case default; flag = .false. end select else flag = any (lhapdf_global_status%initialized) end if end function lhapdf_global_status_is_initialized @ %def lhapdf_global_status_is_initialized <>= subroutine lhapdf_global_status_set_initialized (set) integer, intent(in) :: set lhapdf_global_status%initialized(set) = .true. end subroutine lhapdf_global_status_set_initialized @ %def lhapdf_global_status_set_initialized @ This is the only public procedure, it tells the system to forget about previous initialization, allowing for changing the chosen PDF set. Note that such a feature works only if the global program flow is serial, so no two distinct sets are accessed simultaneously. But this applies to LHAPDF anyway. <>= public :: lhapdf_global_reset <>= subroutine lhapdf_global_reset () lhapdf_global_status%initialized = .false. end subroutine lhapdf_global_reset @ %def lhapdf_global_status_reset @ \subsection{LHAPDF initialization} Before using LHAPDF, we have to initialize it with a particular data set and member. This applies not just if we use structure functions, but also if we just use an $\alpha_s$ formula. The integer [[set]] should be $1$ for proton, $2$ for pion, and $3$ for photon, but this is just convention. It appears as if LHAPDF does not allow for multiple data sets being used concurrently (?), so multi-threaded usage with different sets (e.g., a scan) is excluded. The current setup with a global flag that indicates initialization is fine as long as Whizard itself is run in serial mode at the Sindarin level. If we introduce multithreading in any form from Sindarin, we have to rethink the implementation of the LHAPDF interface. (The same considerations apply to builtin PDFs.) If the particular set has already been initialized, do nothing. This implies that whenever we want to change the setup for a particular set, we have to reset the LHAPDF status. [[lhapdf_initialize]] has an obvious name clash with [[lhapdf_init]], the reason it works for [[pdf_builtin]] is that there things are outsourced to a separate module (inc. [[lhapdf_status]] etc.). <>= public :: lhapdf_initialize <>= subroutine lhapdf_initialize (set, prefix, file, member, pdf, b_match) integer, intent(in) :: set type(string_t), intent(inout) :: prefix type(string_t), intent(inout) :: file type(lhapdf_pdf_t), intent(inout), optional :: pdf integer, intent(inout) :: member logical, intent(in), optional :: b_match if (prefix == "") prefix = LHAPDF_PDFSETS_PATH if (LHAPDF5_AVAILABLE) then if (lhapdf_global_status_is_initialized (set)) return if (file == "") then select case (set) case (1); file = LHAPDF5_DEFAULT_PROTON case (2); file = LHAPDF5_DEFAULT_PION case (3); file = LHAPDF5_DEFAULT_PHOTON end select end if if (data_file_exists (prefix // "/" // file)) then call InitPDFsetM (set, char (prefix // "/" // file)) else call msg_fatal ("LHAPDF: Data file '" & // char (file) // "' not found in '" // char (prefix) // "'.") return end if if (.not. dataset_member_exists (set, member)) then call msg_error (" LHAPDF: Chosen member does not exist for set '" & // char (file) // "', using default.") member = 0 end if call InitPDFM (set, member) else if (LHAPDF6_AVAILABLE) then ! TODO: (bcn 2015-07-07) we should have a closer look why this global ! check must not be executed ! if (lhapdf_global_status_is_initialized (set) .and. & ! pdf%is_associated ()) return if (file == "") then select case (set) case (1); file = LHAPDF6_DEFAULT_PROTON case (2); call msg_fatal ("LHAPDF6: no pion PDFs supported") case (3); call msg_fatal ("LHAPDF6: no photon PDFs supported") end select end if if (data_file_exists (prefix // "/" // file // "/" // file // ".info")) then call pdf%init (char (file), member) else call msg_fatal ("LHAPDF: Data file '" & // char (file) // "' not found in '" // char (prefix) // "'.") return end if end if if (present (b_match)) then if (b_match) then if (LHAPDF5_AVAILABLE) then call hoppet_init (.false.) else if (LHAPDF6_AVAILABLE) then call hoppet_init (.false., pdf) end if end if end if call lhapdf_global_status_set_initialized (set) contains function data_file_exists (fq_name) result (exist) type(string_t), intent(in) :: fq_name logical :: exist inquire (file = char(fq_name), exist = exist) end function data_file_exists function dataset_member_exists (set, member) result (exist) integer, intent(in) :: set, member logical :: exist integer :: n_members call numberPDFM (set, n_members) exist = member >= 0 .and. member <= n_members end function dataset_member_exists end subroutine lhapdf_initialize @ %def lhapdf_initialize @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => lhapdf_complete_kinematics <>= subroutine lhapdf_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("LHAPDF: map flag not supported") else x(1) = r(1) xb(1)= rb(1) f = 1 end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 f = 0 end select end subroutine lhapdf_complete_kinematics @ %def lhapdf_complete_kinematics @ Overriding the default method: we compute the [[x]] value from the momentum configuration. In this specific case, we also set the internally stored $x$ value, so it can be used in the following routine. <>= procedure :: recover_x => lhapdf_recover_x <>= subroutine lhapdf_recover_x (sf_int, x, xb, x_free) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) end subroutine lhapdf_recover_x @ %def lhapdf_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => lhapdf_inverse_kinematics <>= subroutine lhapdf_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("LHAPDF: map flag not supported") else r(1) = x(1) rb(1)= xb(1) f = 1 end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine lhapdf_inverse_kinematics @ %def lhapdf_inverse_kinematics @ \subsection{The LHAPDF data block} The data block holds the incoming flavor (which has to be proton, pion, or photon), the corresponding pointer to the global access data (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the bounds as returned by LHAPDF for the specified set, and a mask that determines which partons will be actually in use. <>= public :: lhapdf_data_t <>= type, extends (sf_data_t) :: lhapdf_data_t private type(string_t) :: prefix type(string_t) :: file type(lhapdf_pdf_t) :: pdf integer :: member = 0 class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in integer :: set = 0 logical :: invert = .false. logical :: photon = .false. logical :: has_photon = .false. integer :: photon_scheme = 0 real(default) :: xmin = 0, xmax = 0 real(default) :: qmin = 0, qmax = 0 logical, dimension(-6:6) :: mask = .true. logical :: mask_photon = .true. logical :: hoppet_b_matching = .false. contains <> end type lhapdf_data_t @ %def lhapdf_data_t @ Generate PDF data. This is provided as a function, but it has the side-effect of initializing the requested PDF set. A finalizer is not needed. The library uses double precision, so since the default precision may be extended or quadruple, we use auxiliary variables for type casting. <>= procedure :: init => lhapdf_data_init <>= subroutine lhapdf_data_init & (data, model, pdg_in, prefix, file, member, photon_scheme, & hoppet_b_matching) class(lhapdf_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in type(string_t), intent(in), optional :: prefix, file integer, intent(in), optional :: member integer, intent(in), optional :: photon_scheme logical, intent(in), optional :: hoppet_b_matching double precision :: xmin, xmax, q2min, q2max external :: InitPDFsetM, InitPDFM, numberPDFM external :: GetXminM, GetXmaxM, GetQ2minM, GetQ2maxM if (.not. LHAPDF5_AVAILABLE .and. .not. LHAPDF6_AVAILABLE) then call msg_fatal ("LHAPDF requested but library is not linked") return end if data%model => model if (pdg_array_get_length (pdg_in) /= 1) & call msg_fatal ("PDF: incoming particle must be unique") call data%flv_in%init (pdg_array_get (pdg_in, 1), model) select case (pdg_array_get (pdg_in, 1)) case (PROTON) data%set = 1 case (-PROTON) data%set = 1 data%invert = .true. case (PIPLUS) data%set = 2 case (-PIPLUS) data%set = 2 data%invert = .true. case (PHOTON) data%set = 3 data%photon = .true. if (present (photon_scheme)) data%photon_scheme = photon_scheme case default call msg_fatal (" LHAPDF: " & // "incoming particle must be (anti)proton, pion, or photon.") return end select if (present (prefix)) then data%prefix = prefix else data%prefix = "" end if if (present (file)) then data%file = file else data%file = "" end if if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching if (LHAPDF5_AVAILABLE) then call lhapdf_initialize (data%set, & data%prefix, data%file, data%member, & b_match = data%hoppet_b_matching) call GetXminM (data%set, data%member, xmin) call GetXmaxM (data%set, data%member, xmax) call GetQ2minM (data%set, data%member, q2min) call GetQ2maxM (data%set, data%member, q2max) data%xmin = xmin data%xmax = xmax data%qmin = sqrt (q2min) data%qmax = sqrt (q2max) data%has_photon = has_photon () else if (LHAPDF6_AVAILABLE) then call lhapdf_initialize (data%set, & data%prefix, data%file, data%member, & data%pdf, data%hoppet_b_matching) data%xmin = data%pdf%getxmin () data%xmax = data%pdf%getxmax () data%qmin = sqrt(data%pdf%getq2min ()) data%qmax = sqrt(data%pdf%getq2max ()) data%has_photon = data%pdf%has_photon () end if end subroutine lhapdf_data_init @ %def lhapdf_data_init @ Enable/disable partons explicitly. If a mask entry is true, applying the PDF will generate the corresponding flavor on output. <>= procedure :: set_mask => lhapdf_data_set_mask <>= subroutine lhapdf_data_set_mask (data, mask) class(lhapdf_data_t), intent(inout) :: data logical, dimension(-6:6), intent(in) :: mask data%mask = mask end subroutine lhapdf_data_set_mask @ %def lhapdf_data_set_mask @ Return the public part of the data set. <>= public :: lhapdf_data_get_public_info <>= subroutine lhapdf_data_get_public_info & (data, lhapdf_dir, lhapdf_file, lhapdf_member) type(lhapdf_data_t), intent(in) :: data type(string_t), intent(out) :: lhapdf_dir, lhapdf_file integer, intent(out) :: lhapdf_member lhapdf_dir = data%prefix lhapdf_file = data%file lhapdf_member = data%member end subroutine lhapdf_data_get_public_info @ %def lhapdf_data_get_public_info @ Return the number of the member of the data set. <>= public :: lhapdf_data_get_set <>= function lhapdf_data_get_set(data) result(set) type(lhapdf_data_t), intent(in) :: data integer :: set set = data%set end function lhapdf_data_get_set @ %def lhapdf_data_get_set @ Output <>= procedure :: write => lhapdf_data_write <>= subroutine lhapdf_data_write (data, unit, verbose) class(lhapdf_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical :: verb integer :: u if (present (verbose)) then verb = verbose else verb = .false. end if u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "LHAPDF data:" if (data%set /= 0) then write (u, "(3x,A)", advance="no") "flavor = " call data%flv_in%write (u); write (u, *) if (verb) then write (u, "(3x,A,A)") " prefix = ", char (data%prefix) else write (u, "(3x,A,A)") " prefix = ", & " " end if write (u, "(3x,A,A)") " file = ", char (data%file) write (u, "(3x,A,I3)") " member = ", data%member write (u, "(3x,A," // FMT_19 // ")") " x(min) = ", data%xmin write (u, "(3x,A," // FMT_19 // ")") " x(max) = ", data%xmax write (u, "(3x,A," // FMT_19 // ")") " Q(min) = ", data%qmin write (u, "(3x,A," // FMT_19 // ")") " Q(max) = ", data%qmax write (u, "(3x,A,L1)") " invert = ", data%invert if (data%photon) write (u, "(3x,A,I3)") & " IP2 (scheme) = ", data%photon_scheme write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") & " mask = ", & data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6) write (u, "(3x,A,L1)") " photon mask = ", data%mask_photon if (data%set == 1) write (u, "(3x,A,L1)") & " hoppet_b = ", data%hoppet_b_matching else write (u, "(3x,A)") "[undefined]" end if end subroutine lhapdf_data_write @ %def lhapdf_data_write @ The number of parameters is one. We do not generate transverse momentum. <>= procedure :: get_n_par => lhapdf_data_get_n_par <>= function lhapdf_data_get_n_par (data) result (n) class(lhapdf_data_t), intent(in) :: data integer :: n n = 1 end function lhapdf_data_get_n_par @ %def lhapdf_data_get_n_par @ Return the outgoing particle PDG codes. This is based on the mask. <>= procedure :: get_pdg_out => lhapdf_data_get_pdg_out <>= subroutine lhapdf_data_get_pdg_out (data, pdg_out) class(lhapdf_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: n, np, i n = count (data%mask) np = 0; if (data%has_photon .and. data%mask_photon) np = 1 allocate (pdg1 (n + np)) pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask) if (np == 1) pdg1(n+np) = PHOTON pdg_out(1) = pdg1 end subroutine lhapdf_data_get_pdg_out @ %def lhapdf_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => lhapdf_data_allocate_sf_int <>= subroutine lhapdf_data_allocate_sf_int (data, sf_int) class(lhapdf_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (lhapdf_t :: sf_int) end subroutine lhapdf_data_allocate_sf_int @ %def lhapdf_data_allocate_sf_int @ Return the numerical PDF set index. <>= procedure :: get_pdf_set => lhapdf_data_get_pdf_set <>= elemental function lhapdf_data_get_pdf_set (data) result (pdf_set) class(lhapdf_data_t), intent(in) :: data integer :: pdf_set pdf_set = data%set end function lhapdf_data_get_pdf_set @ %def lhapdf_data_get_pdf_set @ \subsection{The LHAPDF object} The [[lhapdf_t]] data type is a $1\to 2$ interaction which describes the splitting of an (anti)proton into a parton and a beam remnant. We stay in the strict forward-splitting limit, but allow some invariant mass for the beam remnant such that the outgoing parton is exactly massless. For a real event, we would replace this by a parton cascade, where the outgoing partons have virtuality as dictated by parton-shower kinematics, and transverse momentum is generated. This is the LHAPDF object which holds input data together with the interaction. We also store the $x$ momentum fraction and the scale, since kinematics and function value are requested at different times. The PDF application is a $1\to 2$ splitting process, where the particles are ordered as (hadron, remnant, parton). Polarization is ignored completely. The beam particle is colorless, while partons and beam remnant carry color. The remnant gets a special flavor code. <>= public :: lhapdf_t <>= type, extends (sf_int_t) :: lhapdf_t type(lhapdf_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: q = 0 real(default) :: s = 0 contains <> end type lhapdf_t @ %def lhapdf_t @ Type string: display the chosen PDF set. <>= procedure :: type_string => lhapdf_type_string <>= function lhapdf_type_string (object) result (string) class(lhapdf_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "LHAPDF: " // object%data%file else string = "LHAPDF: [undefined]" end if end function lhapdf_type_string @ %def lhapdf_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => lhapdf_write <>= subroutine lhapdf_write (object, unit, testflag) class(lhapdf_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "LHAPDF data: [undefined]" end if end subroutine lhapdf_write @ %def lhapdf_write @ Initialize. We know that [[data]] will be of concrete type [[sf_lhapdf_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. <>= procedure :: init => lhapdf_init <>= subroutine lhapdf_init (sf_int, data) class(lhapdf_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(flavor_t) :: flv, flv_remnant type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn integer :: i select type (data) type is (lhapdf_data_t) mask = quantum_numbers_mask (.false., .false., .true.) call col0%init () call sf_int%base_init (mask, [0._default], [0._default], [0._default]) sf_int%data => data do i = -6, 6 if (data%mask(i)) then call qn(1)%init (data%flv_in, col = col0) if (i == 0) then call flv%init (GLUON, data%model) call flv_remnant%init (HADRON_REMNANT_OCTET, data%model) else call flv%init (i, data%model) call flv_remnant%init & (sign (HADRON_REMNANT_TRIPLET, -i), data%model) end if call qn(2)%init ( & flv = flv_remnant, col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init ( & flv = flv, col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if end do if (data%has_photon .and. data%mask_photon) then call flv%init (PHOTON, data%model) call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model) call qn(2)%init (flv = flv_remnant, & col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init (flv = flv, & col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine lhapdf_init @ %def lhapdf_init @ \subsection{Structure function} We have to cast the LHAPDF arguments to/from double precision (possibly from/to extended/quadruple precision), if necessary. Some structure functions can yield negative results (sea quarks close to $x=1$). In an NLO computation, this is perfectly fine and we keep negative values. Unlike total cross sections, PDFs do not have to be positive definite. For LO however, negative PDFs would cause negative event weights so we set these values to zero instead. <>= procedure :: apply => lhapdf_apply <>= subroutine lhapdf_apply (sf_int, scale, negative_sf, rescale, i_sub) class(lhapdf_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: x, s double precision :: xx, qq, ss double precision, dimension(-6:6) :: ff double precision :: fphot complex(default), dimension(:), allocatable :: fc integer :: i, i_sub_opt, j_sub logical :: negative_sf_opt external :: evolvePDFM, evolvePDFpM i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf associate (data => sf_int%data) sf_int%q = scale x = sf_int%x if (present (rescale)) call rescale%apply (x) s = sf_int%s xx = x if (debug2_active (D_BEAMS)) then call msg_debug2 (D_BEAMS, "lhapdf_apply") call msg_debug2 (D_BEAMS, "rescale: ", present(rescale)) call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt) call msg_debug2 (D_BEAMS, "x: ", x) end if qq = min (data%qmax, scale) qq = max (data%qmin, qq) if (.not. data%photon) then if (data%invert) then if (data%has_photon) then if (LHAPDF5_AVAILABLE) then call evolvePDFphotonM & (data%set, xx, qq, ff(6:-6:-1), fphot) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfphotonm & (xx, qq, ff(6:-6:-1), fphot) end if else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff(6:-6:-1)) else if (LHAPDF5_AVAILABLE) then call evolvePDFM (data%set, xx, qq, ff(6:-6:-1)) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfm (xx, qq, ff(6:-6:-1)) end if end if end if else if (data%has_photon) then if (LHAPDF5_AVAILABLE) then call evolvePDFphotonM (data%set, xx, qq, ff, fphot) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfphotonm (xx, qq, ff, fphot) end if else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff) else if (LHAPDF5_AVAILABLE) then call evolvePDFM (data%set, xx, qq, ff) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfm (xx, qq, ff) end if end if end if end if else ss = s if (LHAPDF5_AVAILABLE) then call evolvePDFpM (data%set, xx, qq, & ss, data%photon_scheme, ff) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfpm (xx, qq, ss, & data%photon_scheme, ff) end if end if if (data%has_photon) then allocate (fc (count ([data%mask, data%mask_photon]))) if (negative_sf_opt) then fc = pack ([ff, fphot] / x, [data%mask, data%mask_photon]) else fc = max( pack ([ff, fphot] / x, [data%mask, data%mask_photon]), 0._default) end if else allocate (fc (count (data%mask))) if (negative_sf_opt) then fc = pack (ff / x, data%mask) else fc = max( pack (ff / x, data%mask), 0._default) end if end if end associate if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc) call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))]) sf_int%status = SF_EVALUATED end subroutine lhapdf_apply @ %def apply_lhapdf @ \subsection{Strong Coupling} Since the PDF codes provide a function for computing the running $\alpha_s$ value, we make this available as an implementation of the abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation. <>= public :: alpha_qcd_lhapdf_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_lhapdf_t type(string_t) :: pdfset_dir type(string_t) :: pdfset_file integer :: pdfset_member = -1 type(lhapdf_pdf_t) :: pdf contains <> end type alpha_qcd_lhapdf_t @ %def alpha_qcd_lhapdf_t @ Output. As in earlier versions we leave the LHAPDF path out. <>= procedure :: write => alpha_qcd_lhapdf_write <>= subroutine alpha_qcd_lhapdf_write (object, unit) class(alpha_qcd_lhapdf_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A)") "QCD parameters (lhapdf):" write (u, "(5x,A,A)") "PDF set = ", char (object%pdfset_file) write (u, "(5x,A,I0)") "PDF member = ", object%pdfset_member end subroutine alpha_qcd_lhapdf_write @ %def alpha_qcd_lhapdf_write @ Calculation: the numeric member ID selects the correct PDF set, which must be properly initialized. <>= interface double precision function alphasPDF (Q) double precision, intent(in) :: Q end function alphasPDF end interface @ %def alphasPDF @ <>= procedure :: get => alpha_qcd_lhapdf_get <>= function alpha_qcd_lhapdf_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha if (LHAPDF5_AVAILABLE) then alpha = alphasPDF (dble (scale)) else if (LHAPDF6_AVAILABLE) then alpha = alpha_qcd%pdf%alphas_pdf (dble (scale)) end if end function alpha_qcd_lhapdf_get @ %def alpha_qcd_lhapdf_get @ Initialization. We need to access the (quasi-global) initialization status. <>= procedure :: init => alpha_qcd_lhapdf_init <>= subroutine alpha_qcd_lhapdf_init (alpha_qcd, file, member, path) class(alpha_qcd_lhapdf_t), intent(out) :: alpha_qcd type(string_t), intent(inout) :: file integer, intent(inout) :: member type(string_t), intent(inout) :: path alpha_qcd%pdfset_file = file alpha_qcd%pdfset_member = member if (alpha_qcd%pdfset_member < 0) & call msg_fatal ("QCD parameter initialization: PDF set " & // char (file) // " is unknown") if (LHAPDF5_AVAILABLE) then call lhapdf_initialize (1, path, file, member) else if (LHAPDF6_AVAILABLE) then call lhapdf_initialize & (1, path, file, member, alpha_qcd%pdf) end if end subroutine alpha_qcd_lhapdf_init @ %def alpha_qcd_lhapdf_init @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_lhapdf_ut.f90]]>>= <> module sf_lhapdf_ut use unit_tests use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use sf_lhapdf_uti <> <> contains <> end module sf_lhapdf_ut @ %def sf_lhapdf_ut @ <<[[sf_lhapdf_uti.f90]]>>= <> module sf_lhapdf_uti <> <> use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use os_interface use physics_defs, only: PROTON use sm_qcd use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_base use sf_lhapdf <> <> contains <> end module sf_lhapdf_uti @ %def sf_lhapdf_ut @ API: driver for the unit tests below. <>= public :: sf_lhapdf_test <>= subroutine sf_lhapdf_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_lhapdf_test @ %def sf_lhapdf_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_1, "sf_lhapdf5_1", & "structure function configuration", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_1, "sf_lhapdf6_1", & "structure function configuration", & u, results) end if <>= public :: sf_lhapdf_1 <>= subroutine sf_lhapdf_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_lhapdf_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_sm_test () pdg_in = PROTON allocate (lhapdf_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (lhapdf_data_t) call data%init (model, pdg_in) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_1" end subroutine sf_lhapdf_1 @ %def sf_lhapdf_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_2, "sf_lhapdf5_2", & "structure function instance", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_2, "sf_lhapdf6_2", & "structure function instance", & u, results) end if <>= public :: sf_lhapdf_2 <>= subroutine sf_lhapdf_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_lhapdf_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (PROTON, model) pdg_in = PROTON call lhapdf_global_reset () call reset_interaction_counter () allocate (lhapdf_data_t :: data) select type (data) type is (lhapdf_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100 GeV" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 100._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_2" end subroutine sf_lhapdf_2 @ %def sf_lhapdf_2 @ \subsubsection{Strong Coupling} Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract type. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_3, "sf_lhapdf5_3", & "running alpha_s", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_3, "sf_lhapdf6_3", & "running alpha_s", & u, results) end if <>= public :: sf_lhapdf_3 <>= subroutine sf_lhapdf_3 (u) integer, intent(in) :: u type(qcd_t) :: qcd type(string_t) :: name, path integer :: member write (u, "(A)") "* Test output: sf_lhapdf_3" write (u, "(A)") "* Purpose: initialize and evaluate alpha_s" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call lhapdf_global_reset () if (LHAPDF5_AVAILABLE) then name = "cteq6ll.LHpdf" member = 1 path = "" else if (LHAPDF6_AVAILABLE) then name = "CT10" member = 1 path = "" end if write (u, "(A)") "* Initialize qcd object" write (u, "(A)") allocate (alpha_qcd_lhapdf_t :: qcd%alpha) select type (alpha => qcd%alpha) type is (alpha_qcd_lhapdf_t) call alpha%init (name, member, path) end select call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100" write (u, "(A)") write (u, "(1x,A,F8.5)") "alpha = ", qcd%alpha%get (100._default) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_3" end subroutine sf_lhapdf_3 @ %def sf_lhapdf_3 @ \section{Easy PDF Access} For the shower, subtraction and matching, it is very useful to have direct access to $f(x,Q)$ independently of the used library. <<[[pdf.f90]]>>= <> module pdf <> use io_units use system_dependencies, only: LHAPDF5_AVAILABLE, LHAPDF6_AVAILABLE use diagnostics use beam_structures use lhapdf !NODEP! use pdf_builtin !NODEP! <> <> <> <> contains <> end module pdf @ %def pdf We support the following implementations: <>= integer, parameter, public :: STRF_NONE = 0 integer, parameter, public :: STRF_LHAPDF6 = 1 integer, parameter, public :: STRF_LHAPDF5 = 2 integer, parameter, public :: STRF_PDF_BUILTIN = 3 @ %def STRF_NONE STRF_LHAPDF6 STRF_LHAPDF5 STRF_PDF_BUILTIN @ A container to bundle all necessary PDF data. Could be moved to a more central location. <>= public :: pdf_data_t <>= type :: pdf_data_t type(lhapdf_pdf_t) :: pdf real(default) :: xmin, xmax, qmin, qmax integer :: type = STRF_NONE integer :: set = 0 contains <> end type pdf_data_t @ %def pdf_data @ <>= procedure :: init => pdf_data_init <>= subroutine pdf_data_init (pdf_data, pdf_data_in) class(pdf_data_t), intent(out) :: pdf_data type(pdf_data_t), target, intent(in) :: pdf_data_in pdf_data%xmin = pdf_data_in%xmin pdf_data%xmax = pdf_data_in%xmax pdf_data%qmin = pdf_data_in%qmin pdf_data%qmax = pdf_data_in%qmax pdf_data%set = pdf_data_in%set pdf_data%type = pdf_data_in%type if (pdf_data%type == STRF_LHAPDF6) then if (pdf_data_in%pdf%is_associated ()) then call lhapdf_copy_pointer (pdf_data_in%pdf, pdf_data%pdf) else call msg_bug ('pdf_data_init: pdf_data%pdf was not associated!') end if end if end subroutine pdf_data_init @ %def pdf_data_init @ <>= procedure :: write => pdf_data_write <>= subroutine pdf_data_write (pdf_data, unit) class(pdf_data_t), intent(in) :: pdf_data integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A,I0)") "PDF set = ", pdf_data%set write (u, "(3x,A,I0)") "PDF type = ", pdf_data%type end subroutine pdf_data_write @ %def pdf_data_write @ <>= procedure :: setup => pdf_data_setup <>= subroutine pdf_data_setup (pdf_data, caller, beam_structure, lhapdf_member, set) class(pdf_data_t), intent(inout) :: pdf_data character(len=*), intent(in) :: caller type(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: lhapdf_member, set real(default) :: xmin, xmax, q2min, q2max pdf_data%set = set if (beam_structure%contains ("lhapdf")) then if (LHAPDF6_AVAILABLE) then pdf_data%type = STRF_LHAPDF6 else if (LHAPDF5_AVAILABLE) then pdf_data%type = STRF_LHAPDF5 end if write (msg_buffer, "(A,I0)") caller & // ": interfacing LHAPDF set #", pdf_data%set call msg_message () else if (beam_structure%contains ("pdf_builtin")) then pdf_data%type = STRF_PDF_BUILTIN write (msg_buffer, "(A,I0)") caller & // ": interfacing PDF builtin set #", pdf_data%set call msg_message () end if select case (pdf_data%type) case (STRF_LHAPDF6) pdf_data%xmin = pdf_data%pdf%getxmin () pdf_data%xmax = pdf_data%pdf%getxmax () pdf_data%qmin = sqrt(pdf_data%pdf%getq2min ()) pdf_data%qmax = sqrt(pdf_data%pdf%getq2max ()) case (STRF_LHAPDF5) call GetXminM (1, lhapdf_member, xmin) call GetXmaxM (1, lhapdf_member, xmax) call GetQ2minM (1, lhapdf_member, q2min) call GetQ2maxM (1, lhapdf_member, q2max) pdf_data%xmin = xmin pdf_data%xmax = xmax pdf_data%qmin = sqrt(q2min) pdf_data%qmax = sqrt(q2max) end select end subroutine pdf_data_setup @ %def pdf_data_setup @ This could be overloaded with a version that only asks for a specific flavor as it is supported by LHAPDF6. <>= procedure :: evolve => pdf_data_evolve <>= subroutine pdf_data_evolve (pdf_data, x, q_in, f) class(pdf_data_t), intent(inout) :: pdf_data real(double), intent(in) :: x, q_in real(double), dimension(-6:6), intent(out) :: f real(double) :: q select case (pdf_data%type) case (STRF_PDF_BUILTIN) call pdf_evolve_LHAPDF (pdf_data%set, x, q_in, f) case (STRF_LHAPDF6) q = min (pdf_data%qmax, q_in) q = max (pdf_data%qmin, q) call pdf_data%pdf%evolve_pdfm (x, q, f) case (STRF_LHAPDF5) q = min (pdf_data%qmax, q_in) q = max (pdf_data%qmin, q) call evolvePDFM (pdf_data%set, x, q, f) case default call msg_fatal ("PDF function: unknown PDF method.") end select end subroutine pdf_data_evolve @ %def pdf_data_evolve @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Dispatch} @ <<[[dispatch_beams.f90]]>>= <> module dispatch_beams <> <> use diagnostics use os_interface, only: os_data_t use variables, only: var_list_t use constants, only: PI, one use numeric_utils, only: vanishes use physics_defs, only: PHOTON use rng_base, only: rng_factory_t use pdg_arrays use model_data, only: model_data_t use dispatch_rng, only: dispatch_rng_factory use dispatch_rng, only: update_rng_seed_in_var_list use flavors, only: flavor_t use sm_qcd, only: qcd_t, alpha_qcd_fixed_t, alpha_qcd_from_scale_t use sm_qcd, only: alpha_qcd_from_lambda_t use sm_qed, only: qed_t, alpha_qed_fixed_t, alpha_qed_from_scale_t use physics_defs, only: MZ_REF, ME_REF, ALPHA_QCD_MZ_REF, ALPHA_QED_ME_REF use beam_structures use sf_base use sf_mappings use sf_isr use sf_epa use sf_ewa use sf_escan use sf_gaussian use sf_beam_events use sf_circe1 use sf_circe2 use sf_pdf_builtin use sf_lhapdf <> <> <> <> contains <> end module dispatch_beams @ %def dispatch_beams @ This data type is a container for transferring structure-function specific data from the [[dispatch_sf_data]] to the [[dispatch_sf_channels]] subroutine. <>= public :: sf_prop_t <>= type :: sf_prop_t real(default), dimension(2) :: isr_eps = 1 end type sf_prop_t @ %def sf_prop_t @ Allocate a structure-function configuration object according to the [[sf_method]] string. The [[sf_prop]] object can be used to transfer structure-function specific data up and to the [[dispatch_sf_channels]] subroutine below, so they can be used for particular mappings. The [[var_list_global]] object is used for the RNG generator seed. It is intent(inout) because the RNG generator seed may change during initialization. The [[pdg_in]] array is the array of incoming flavors, corresponding to the upstream structure function or the beam array. This will be checked for the structure function in question and replaced by the outgoing flavors. The [[pdg_prc]] array is the array of incoming flavors (beam index, component index) for the hard process. <>= public :: dispatch_sf_data <>= subroutine dispatch_sf_data (data, sf_method, i_beam, sf_prop, & var_list, var_list_global, model, & os_data, sqrts, pdg_in, pdg_prc, polarized) class(sf_data_t), allocatable, intent(inout) :: data type(string_t), intent(in) :: sf_method integer, dimension(:), intent(in) :: i_beam type(pdg_array_t), dimension(:), intent(inout) :: pdg_in type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(sf_prop_t), intent(inout) :: sf_prop type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global integer :: next_rng_seed class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts logical, intent(in) :: polarized type(pdg_array_t), dimension(:), allocatable :: pdg_out real(default) :: isr_alpha, isr_q_max, isr_mass integer :: isr_order logical :: isr_recoil, isr_keep_energy real(default) :: epa_alpha, epa_x_min, epa_q_min, epa_q_max, epa_mass logical :: epa_recoil, epa_keep_energy integer :: epa_int_mode type(string_t) :: epa_mode real(default) :: ewa_x_min, ewa_pt_max, ewa_mass logical :: ewa_recoil, ewa_keep_energy type(pdg_array_t), dimension(:), allocatable :: pdg_prc1 integer :: ewa_id type(string_t) :: pdf_name type(string_t) :: lhapdf_dir, lhapdf_file type(string_t), dimension(13) :: lhapdf_photon_sets integer :: lhapdf_member, lhapdf_photon_scheme logical :: hoppet_b_matching class(rng_factory_t), allocatable :: rng_factory logical :: circe1_photon1, circe1_photon2, circe1_generate, & circe1_with_radiation real(default) :: circe1_sqrts, circe1_eps integer :: circe1_version, circe1_chattiness, & circe1_revision character(6) :: circe1_accelerator logical :: circe2_polarized type(string_t) :: circe2_design, circe2_file real(default), dimension(2) :: gaussian_spread logical :: beam_events_warn_eof type(string_t) :: beam_events_dir, beam_events_file logical :: escan_normalize integer :: i lhapdf_photon_sets = [var_str ("DOG0.LHgrid"), var_str ("DOG1.LHgrid"), & var_str ("DGG.LHgrid"), var_str ("LACG.LHgrid"), & var_str ("GSG0.LHgrid"), var_str ("GSG1.LHgrid"), & var_str ("GSG960.LHgrid"), var_str ("GSG961.LHgrid"), & var_str ("GRVG0.LHgrid"), var_str ("GRVG1.LHgrid"), & var_str ("ACFGPG.LHgrid"), var_str ("WHITG.LHgrid"), & var_str ("SASG.LHgrid")] select case (char (sf_method)) case ("pdf_builtin") allocate (pdf_builtin_data_t :: data) select type (data) type is (pdf_builtin_data_t) pdf_name = & var_list%get_sval (var_str ("$pdf_builtin_set")) hoppet_b_matching = & var_list%get_lval (var_str ("?hoppet_b_matching")) call data%init ( & model, pdg_in(i_beam(1)), & name = pdf_name, & path = os_data%pdf_builtin_datapath, & hoppet_b_matching = hoppet_b_matching) end select case ("pdf_builtin_photon") call msg_fatal ("Currently, there are no photon PDFs built into WHIZARD,", & [var_str ("for the photon content inside a proton or neutron use"), & var_str ("the 'lhapdf_photon' structure function.")]) case ("lhapdf") allocate (lhapdf_data_t :: data) if (pdg_array_get (pdg_in(i_beam(1)), 1) == PHOTON) then call msg_fatal ("The 'lhapdf' structure is intended only for protons and", & [var_str ("pions, please use 'lhapdf_photon' for photon beams.")]) end if lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_file")) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) lhapdf_photon_scheme = & var_list%get_ival (var_str ("lhapdf_photon_scheme")) hoppet_b_matching = & var_list%get_lval (var_str ("?hoppet_b_matching")) select type (data) type is (lhapdf_data_t) call data%init & (model, pdg_in(i_beam(1)), & lhapdf_dir, lhapdf_file, lhapdf_member, & lhapdf_photon_scheme, hoppet_b_matching) end select case ("lhapdf_photon") allocate (lhapdf_data_t :: data) if (pdg_array_get_length (pdg_in(i_beam(1))) /= 1 .or. & pdg_array_get (pdg_in(i_beam(1)), 1) /= PHOTON) then call msg_fatal ("The 'lhapdf_photon' structure function is exclusively for", & [var_str ("photon PDFs, i.e. for photons as beam particles")]) end if lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_photon_file")) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) lhapdf_photon_scheme = & var_list%get_ival (var_str ("lhapdf_photon_scheme")) if (.not. any (lhapdf_photon_sets == lhapdf_file)) then call msg_fatal ("This PDF set is not supported or not " // & "intended for photon beams.") end if select type (data) type is (lhapdf_data_t) call data%init & (model, pdg_in(i_beam(1)), & lhapdf_dir, lhapdf_file, lhapdf_member, & lhapdf_photon_scheme) end select case ("isr") allocate (isr_data_t :: data) isr_alpha = & var_list%get_rval (var_str ("isr_alpha")) if (vanishes (isr_alpha)) then isr_alpha = (var_list%get_rval (var_str ("ee"))) & ** 2 / (4 * PI) end if isr_q_max = & var_list%get_rval (var_str ("isr_q_max")) if (vanishes (isr_q_max)) then isr_q_max = sqrts end if isr_mass = var_list%get_rval (var_str ("isr_mass")) isr_order = var_list%get_ival (var_str ("isr_order")) isr_recoil = var_list%get_lval (var_str ("?isr_recoil")) isr_keep_energy = var_list%get_lval (var_str ("?isr_keep_energy")) select type (data) type is (isr_data_t) call data%init & (model, pdg_in (i_beam(1)), isr_alpha, isr_q_max, & isr_mass, isr_order, recoil = isr_recoil, keep_energy = & isr_keep_energy) call data%check () sf_prop%isr_eps(i_beam(1)) = data%get_eps () end select case ("epa") allocate (epa_data_t :: data) epa_mode = var_list%get_sval (var_str ("$epa_mode")) epa_int_mode = 0 epa_alpha = var_list%get_rval (var_str ("epa_alpha")) if (vanishes (epa_alpha)) then epa_alpha = (var_list%get_rval (var_str ("ee"))) & ** 2 / (4 * PI) end if epa_x_min = var_list%get_rval (var_str ("epa_x_min")) epa_q_min = var_list%get_rval (var_str ("epa_q_min")) epa_q_max = var_list%get_rval (var_str ("epa_q_max")) if (vanishes (epa_q_max)) then epa_q_max = sqrts end if select case (char (epa_mode)) case ("default", "Budnev_617") epa_int_mode = 0 case ("Budnev_616e") epa_int_mode = 1 case ("log_power") epa_int_mode = 2 epa_q_max = sqrts case ("log_simple") epa_int_mode = 3 epa_q_max = sqrts case ("log") epa_int_mode = 4 epa_q_max = sqrts case default call msg_fatal ("EPA: unsupported EPA mode; please choose " // & "'default', 'Budnev_616', 'Budnev_616e', 'log_power', " // & "'log_simple', or 'log'") end select epa_mass = var_list%get_rval (var_str ("epa_mass")) epa_recoil = var_list%get_lval (var_str ("?epa_recoil")) epa_keep_energy = var_list%get_lval (var_str ("?epa_keep_energy")) select type (data) type is (epa_data_t) call data%init & (model, epa_int_mode, pdg_in (i_beam(1)), epa_alpha, & epa_x_min, epa_q_min, epa_q_max, epa_mass, & recoil = epa_recoil, keep_energy = epa_keep_energy) call data%check () end select case ("ewa") allocate (ewa_data_t :: data) allocate (pdg_prc1 (size (pdg_prc, 2))) pdg_prc1 = pdg_prc(i_beam(1),:) if (any (pdg_array_get_length (pdg_prc1) /= 1) & .or. any (pdg_prc1 /= pdg_prc1(1))) then call msg_fatal & ("EWA: process incoming particle (W/Z) must be unique") end if ewa_id = abs (pdg_array_get (pdg_prc1(1), 1)) ewa_x_min = var_list%get_rval (var_str ("ewa_x_min")) ewa_pt_max = var_list%get_rval (var_str ("ewa_pt_max")) if (vanishes (ewa_pt_max)) then ewa_pt_max = sqrts end if ewa_mass = var_list%get_rval (var_str ("ewa_mass")) ewa_recoil = var_list%get_lval (& var_str ("?ewa_recoil")) ewa_keep_energy = var_list%get_lval (& var_str ("?ewa_keep_energy")) select type (data) type is (ewa_data_t) call data%init & (model, pdg_in (i_beam(1)), ewa_x_min, & ewa_pt_max, sqrts, ewa_recoil, & ewa_keep_energy, ewa_mass) call data%set_id (ewa_id) call data%check () end select case ("circe1") allocate (circe1_data_t :: data) select type (data) type is (circe1_data_t) circe1_photon1 = & var_list%get_lval (var_str ("?circe1_photon1")) circe1_photon2 = & var_list%get_lval (var_str ("?circe1_photon2")) circe1_sqrts = & var_list%get_rval (var_str ("circe1_sqrts")) circe1_eps = & var_list%get_rval (var_str ("circe1_eps")) if (circe1_sqrts <= 0) circe1_sqrts = sqrts circe1_generate = & var_list%get_lval (var_str ("?circe1_generate")) circe1_version = & var_list%get_ival (var_str ("circe1_ver")) circe1_revision = & var_list%get_ival (var_str ("circe1_rev")) circe1_accelerator = & char (var_list%get_sval (var_str ("$circe1_acc"))) circe1_chattiness = & var_list%get_ival (var_str ("circe1_chat")) circe1_with_radiation = & var_list%get_lval (var_str ("?circe1_with_radiation")) call data%init (model, pdg_in, circe1_sqrts, circe1_eps, & [circe1_photon1, circe1_photon2], & circe1_version, circe1_revision, circe1_accelerator, & circe1_chattiness, circe1_with_radiation) if (circe1_generate) then call msg_message ("CIRCE1: activating generator mode") call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%set_generator_mode (rng_factory) end if end select case ("circe2") allocate (circe2_data_t :: data) select type (data) type is (circe2_data_t) circe2_polarized = & var_list%get_lval (var_str ("?circe2_polarized")) circe2_file = & var_list%get_sval (var_str ("$circe2_file")) circe2_design = & var_list%get_sval (var_str ("$circe2_design")) call data%init (os_data, model, pdg_in, sqrts, & circe2_polarized, polarized, circe2_file, circe2_design) call msg_message ("CIRCE2: activating generator mode") call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%set_generator_mode (rng_factory) end select case ("gaussian") allocate (gaussian_data_t :: data) select type (data) type is (gaussian_data_t) gaussian_spread = & [var_list%get_rval (var_str ("gaussian_spread1")), & var_list%get_rval (var_str ("gaussian_spread2"))] call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%init (model, pdg_in, gaussian_spread, rng_factory) end select case ("beam_events") allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) beam_events_dir = os_data%whizard_beamsimpath beam_events_file = var_list%get_sval (& var_str ("$beam_events_file")) beam_events_warn_eof = var_list%get_lval (& var_str ("?beam_events_warn_eof")) call data%init (model, pdg_in, & beam_events_dir, beam_events_file, beam_events_warn_eof) end select case ("energy_scan") escan_normalize = & var_list%get_lval (var_str ("?energy_scan_normalize")) allocate (escan_data_t :: data) select type (data) type is (escan_data_t) if (escan_normalize) then call data%init (model, pdg_in) else call data%init (model, pdg_in, sqrts) end if end select case default if (associated (dispatch_sf_data_extra)) then call dispatch_sf_data_extra (data, sf_method, i_beam, & sf_prop, var_list, var_list_global, model, os_data, sqrts, pdg_in, & pdg_prc, polarized) end if if (.not. allocated (data)) then call msg_fatal ("Structure function '" & // char (sf_method) // "' not implemented") end if end select if (allocated (data)) then allocate (pdg_out (size (pdg_prc, 1))) call data%get_pdg_out (pdg_out) do i = 1, size (i_beam) pdg_in(i_beam(i)) = pdg_out(i) end do end if end subroutine dispatch_sf_data @ %def dispatch_sf_data @ This is a hook that allows us to inject further handlers for structure-function objects, in particular a test structure function. <>= public :: dispatch_sf_data_extra <>= procedure (dispatch_sf_data), pointer :: & dispatch_sf_data_extra => null () @ %def dispatch_sf_data_extra @ This is an auxiliary procedure, used by the beam-structure expansion: tell for a given structure function name, whether it corresponds to a pair spectrum ($n=2$), a single-particle structure function ($n=1$), or nothing ($n=0$). Though [[energy_scan]] can in principle also be a pair spectrum, it always has only one parameter. <>= public :: strfun_mode <>= function strfun_mode (name) result (n) type(string_t), intent(in) :: name integer :: n select case (char (name)) case ("none") n = 0 case ("sf_test_0", "sf_test_1") n = 1 case ("pdf_builtin","pdf_builtin_photon", & "lhapdf","lhapdf_photon") n = 1 case ("isr","epa","ewa") n = 1 case ("circe1", "circe2") n = 2 case ("gaussian") n = 2 case ("beam_events") n = 2 case ("energy_scan") n = 2 case default n = -1 call msg_bug ("Structure function '" // char (name) & // "' not supported yet") end select end function strfun_mode @ %def strfun_mode @ Dispatch a whole structure-function chain, given beam data and beam structure data. This could be done generically, but we should look at the specific combination of structure functions in order to select appropriate mappings. The [[beam_structure]] argument gets copied because we want to expand it to canonical form (one valid structure-function entry per record) before proceeding further. The [[pdg_prc]] argument is the array of incoming flavors. The first index is the beam index, the second one the process component index. Each element is itself a PDG array, notrivial if there is a flavor sum for the incoming state of this component. The dispatcher is divided in two parts. The first part configures the structure function data themselves. After this, we can configure the phase space for the elementary process. <>= public :: dispatch_sf_config <>= subroutine dispatch_sf_config (sf_config, sf_prop, beam_structure, & var_list, var_list_global, model, os_data, sqrts, pdg_prc) type(sf_config_t), dimension(:), allocatable, intent(out) :: sf_config type(sf_prop_t), intent(out) :: sf_prop type(beam_structure_t), intent(inout) :: beam_structure type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts class(sf_data_t), allocatable :: sf_data type(beam_structure_t) :: beam_structure_tmp type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(string_t), dimension(:), allocatable :: prt_in type(pdg_array_t), dimension(:), allocatable :: pdg_in type(flavor_t) :: flv_in integer :: n_beam, n_record, i beam_structure_tmp = beam_structure call beam_structure_tmp%expand (strfun_mode) n_record = beam_structure_tmp%get_n_record () allocate (sf_config (n_record)) n_beam = beam_structure_tmp%get_n_beam () if (n_beam > 0) then allocate (prt_in (n_beam), pdg_in (n_beam)) prt_in = beam_structure_tmp%get_prt () do i = 1, n_beam call flv_in%init (prt_in(i), model) pdg_in(i) = flv_in%get_pdg () end do else n_beam = size (pdg_prc, 1) allocate (pdg_in (n_beam)) pdg_in = pdg_prc(:,1) end if do i = 1, n_record call dispatch_sf_data (sf_data, & beam_structure_tmp%get_name (i), & beam_structure_tmp%get_i_entry (i), & sf_prop, var_list, var_list_global, model, os_data, sqrts, & pdg_in, pdg_prc, & beam_structure_tmp%polarized ()) call sf_config(i)%init (beam_structure_tmp%get_i_entry (i), sf_data) deallocate (sf_data) end do end subroutine dispatch_sf_config @ %def dispatch_sf_config @ \subsection{QCD and QED coupling} Allocate the [[alpha]] (running coupling) component of the [[qcd]] block with a concrete implementation, depending on the variable settings in the [[global]] record. If a fixed $\alpha_s$ is requested, we do not allocate the [[qcd%alpha]] object. In this case, the matrix element code will just take the model parameter as-is, which implies fixed $\alpha_s$. If the object is allocated, the $\alpha_s$ value is computed and updated for each matrix-element call. Also fetch the [[alphas_nf]] variable from the list and store it in the QCD record. This is not used in the $\alpha_s$ calculation, but the QCD record thus becomes a messenger for this user parameter. <>= public :: dispatch_qcd <>= subroutine dispatch_qcd (qcd, var_list, os_data) type(qcd_t), intent(inout) :: qcd type(var_list_t), intent(in) :: var_list type(os_data_t), intent(in) :: os_data logical :: fixed, from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd real(default) :: mz, alpha_val, lambda integer :: nf, order, lhapdf_member type(string_t) :: pdfset, lhapdf_dir, lhapdf_file call unpack_variables () if (allocated (qcd%alpha)) deallocate (qcd%alpha) if (from_lhapdf .and. from_pdf_builtin) then call msg_fatal (" Mixing alphas evolution", & [var_str (" from LHAPDF and builtin PDF is not permitted")]) end if select case (count ([from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd])) case (0) if (fixed) then allocate (alpha_qcd_fixed_t :: qcd%alpha) else call msg_fatal ("QCD alpha: no calculation mode set") end if case (2:) call msg_fatal ("QCD alpha: calculation mode is ambiguous") case (1) if (fixed) then call msg_fatal ("QCD alpha: use '?alphas_is_fixed = false' for " // & "running alphas") else if (from_mz) then allocate (alpha_qcd_from_scale_t :: qcd%alpha) else if (from_pdf_builtin) then allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha) else if (from_lhapdf) then allocate (alpha_qcd_lhapdf_t :: qcd%alpha) else if (from_lambda_qcd) then allocate (alpha_qcd_from_lambda_t :: qcd%alpha) end if call msg_message ("QCD alpha: using a running strong coupling") end select call init_alpha () qcd%n_f = var_list%get_ival (var_str ("alphas_nf")) contains <> end subroutine dispatch_qcd @ %def dispatch_qcd @ <>= subroutine unpack_variables () fixed = var_list%get_lval (var_str ("?alphas_is_fixed")) from_mz = var_list%get_lval (var_str ("?alphas_from_mz")) from_pdf_builtin = & var_list%get_lval (var_str ("?alphas_from_pdf_builtin")) from_lhapdf = & var_list%get_lval (var_str ("?alphas_from_lhapdf")) from_lambda_qcd = & var_list%get_lval (var_str ("?alphas_from_lambda_qcd")) pdfset = var_list%get_sval (var_str ("$pdf_builtin_set")) lambda = var_list%get_rval (var_str ("lambda_qcd")) nf = var_list%get_ival (var_str ("alphas_nf")) order = var_list%get_ival (var_str ("alphas_order")) lhapdf_dir = var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = var_list%get_sval (var_str ("$lhapdf_file")) lhapdf_member = var_list%get_ival (var_str ("lhapdf_member")) if (var_list%contains (var_str ("mZ"))) then mz = var_list%get_rval (var_str ("mZ")) else mz = MZ_REF end if if (var_list%contains (var_str ("alphas"))) then alpha_val = var_list%get_rval (var_str ("alphas")) else alpha_val = ALPHA_QCD_MZ_REF end if end subroutine unpack_variables @ <>= subroutine init_alpha () select type (alpha => qcd%alpha) type is (alpha_qcd_fixed_t) alpha%val = alpha_val type is (alpha_qcd_from_scale_t) alpha%mu_ref = mz alpha%ref = alpha_val alpha%order = order alpha%nf = nf type is (alpha_qcd_from_lambda_t) alpha%lambda = lambda alpha%order = order alpha%nf = nf type is (alpha_qcd_pdf_builtin_t) call alpha%init (pdfset, & os_data%pdf_builtin_datapath) type is (alpha_qcd_lhapdf_t) call alpha%init (lhapdf_file, lhapdf_member, lhapdf_dir) end select end subroutine init_alpha @ @ Same for QED. <>= public :: dispatch_qed <>= subroutine dispatch_qed (qed, var_list) type(qed_t), intent(inout) :: qed type(var_list_t), intent(in) :: var_list logical :: fixed, from_me, analytic real(default) :: me, alpha_val integer :: nf, nlep, order call unpack_variables () if (allocated (qed%alpha)) deallocate (qed%alpha) select case (count ([from_me])) case (0) if (fixed) then allocate (alpha_qed_fixed_t :: qed%alpha) else call msg_fatal ("QED alpha: no calculation mode set") end if case (2:) call msg_fatal ("QED alpha: calculation mode is ambiguous") case (1) if (fixed) then call msg_fatal ("QED alpha: use '?alphas_is_fixed = false' for " // & "running alpha") else if (from_me) then allocate (alpha_qed_from_scale_t :: qed%alpha) end if call msg_message ("QED alpha: using a running electromagnetic coupling") end select call init_alpha () if (var_list%get_ival (var_str ("alpha_nf")) == -1) then qed%n_f = var_list%get_ival (var_str ("alphas_nf")) else qed%n_f = var_list%get_ival (var_str ("alpha_nf")) end if qed%n_lep = var_list%get_ival (var_str ("alpha_nlep")) contains <> end subroutine dispatch_qed @ %def dispatch_qed @ <>= subroutine unpack_variables () fixed = var_list%get_lval (var_str ("?alpha_is_fixed")) from_me = var_list%get_lval (var_str ("?alpha_from_me")) if (var_list%get_ival (var_str ("alpha_nf")) == -1) then nf = var_list%get_ival (var_str ("alphas_nf")) else nf = var_list%get_ival (var_str ("alpha_nf")) end if analytic = var_list%get_lval (var_str ("?alpha_evolve_analytic")) nlep = var_list%get_ival (var_str ("alpha_nlep")) order = var_list%get_ival (var_str ("alpha_order")) if (var_list%contains (var_str ("me"))) then me = var_list%get_rval (var_str ("me")) else me = ME_REF end if if (var_list%contains (var_str ("alpha_em_i"))) then alpha_val = one / var_list%get_rval (var_str ("alpha_em_i")) else alpha_val = ALPHA_QED_ME_REF end if end subroutine unpack_variables @ <>= subroutine init_alpha () select type (alpha => qed%alpha) type is (alpha_qed_fixed_t) alpha%val = alpha_val type is (alpha_qed_from_scale_t) alpha%mu_ref = me alpha%ref = alpha_val alpha%order = order alpha%nf = nf alpha%nlep = nlep alpha%analytic = analytic end select end subroutine init_alpha @ Index: trunk/src/mci/mci.nw =================================================================== --- trunk/src/mci/mci.nw (revision 8775) +++ trunk/src/mci/mci.nw (revision 8776) @@ -1,14238 +1,14239 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; noweb-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: integration and event generation %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Multi-Channel Integration} \includemodulegraph{mci} The abstract representation of multi-channel Monte Carlo algorithms for integration and event generation. \begin{description} \item[Module [[mci_base]]:] The abstract types and their methods. It provides a test integrator that is referenced in later unit tests. \item[iterations] Container for defining integration call and pass settings. \item[integration\_results] This module handles results from integrating processes. It records passes and iterations, calculates statistical averages, and provides the user output of integration results. \end{description} These are the implementations: \begin{description} \item[Module [[mci_midpoint]]:] A simple integrator that uses the midpoint rule to sample the integrand uniformly over the unit hypercube. There is only one integration channel, so this can be matched only to single-channel phase space. \item[Module [[mci_vamp]]:] Interface for the VAMP package. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \clearpage \section{Generic Integrator} This module provides a multi-channel integrator (MCI) base type, a corresponding configuration type, and methods for integration and event generation. <<[[mci_base.f90]]>>= <> module mci_base use kinds use io_units use format_utils, only: pac_fmt use format_defs, only: FMT_14, FMT_17 use diagnostics use cputime use phs_base use rng_base <> <> <> <> contains <> end module mci_base @ %def mci_base @ \subsection{MCI: integrator} The MCI object contains the methods for integration and event generation. For the actual work and data storage, it spawns an MCI instance object. The base object contains the number of integration dimensions and the number of channels as configuration data. Further configuration data are stored in the concrete extensions. The MCI sum contains all relevant information about the integrand. It can be used for comparing the current configuration against a previous one. If they match, we can skip an actual integration. (Implemented only for the VAMP version.) There is a random-number generator (its state with associated methods) available as [[rng]]. It may or may not be used for integration. It will be used for event generation. <>= public :: mci_t <>= type, abstract :: mci_t integer :: n_dim = 0 integer :: n_channel = 0 integer :: n_chain = 0 integer, dimension(:), allocatable :: chain real(default), dimension(:), allocatable :: chain_weights character(32) :: md5sum = "" logical :: integral_known = .false. logical :: error_known = .false. logical :: efficiency_known = .false. real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 logical :: use_timer = .false. type(timer_t) :: timer class(rng_t), allocatable :: rng contains <> end type mci_t @ %def mci_t @ Finalizer: the random-number generator may need one. <>= procedure :: base_final => mci_final procedure (mci_final), deferred :: final <>= subroutine mci_final (object) class(mci_t), intent(inout) :: object if (allocated (object%rng)) call object%rng%final () end subroutine mci_final @ %def mci_final @ Output: basic and extended output. <>= procedure :: base_write => mci_write procedure (mci_write), deferred :: write <>= subroutine mci_write (object, unit, pacify, md5sum_version) class(mci_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version logical :: md5sum_ver integer :: u, i, j character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) md5sum_ver = .false. if (present (md5sum_version)) md5sum_ver = md5sum_version if (object%use_timer .and. .not. md5sum_ver) then write (u, "(2x)", advance="no") call object%timer%write (u) end if if (object%integral_known) then write (u, "(3x,A," // fmt // ")") & "Integral = ", object%integral end if if (object%error_known) then write (u, "(3x,A," // fmt // ")") & "Error = ", object%error end if if (object%efficiency_known) then write (u, "(3x,A," // fmt // ")") & "Efficiency = ", object%efficiency end if write (u, "(3x,A,I0)") "Number of channels = ", object%n_channel write (u, "(3x,A,I0)") "Number of dimensions = ", object%n_dim if (object%n_chain > 0) then write (u, "(3x,A,I0)") "Number of chains = ", object%n_chain write (u, "(3x,A)") "Chains:" do i = 1, object%n_chain write (u, "(5x,I0,':')", advance = "no") i do j = 1, object%n_channel if (object%chain(j) == i) & write (u, "(1x,I0)", advance = "no") j end do write (u, "(A)") end do end if end subroutine mci_write @ %def mci_write @ Print an informative message when starting integration. <>= procedure (mci_startup_message), deferred :: startup_message procedure :: base_startup_message => mci_startup_message <>= subroutine mci_startup_message (mci, unit, n_calls) class(mci_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls if (mci%n_chain > 0) then write (msg_buffer, "(A,3(1x,I0,1x,A))") & "Integrator:", mci%n_chain, "chains,", & mci%n_channel, "channels,", & mci%n_dim, "dimensions" else write (msg_buffer, "(A,3(1x,I0,1x,A))") & "Integrator:", & mci%n_channel, "channels,", & mci%n_dim, "dimensions" end if call msg_message (unit = unit) end subroutine mci_startup_message @ %def mci_startup_message @ Dump type-specific info to a logfile. <>= procedure(mci_write_log_entry), deferred :: write_log_entry <>= abstract interface subroutine mci_write_log_entry (mci, u) import class(mci_t), intent(in) :: mci integer, intent(in) :: u end subroutine mci_write_log_entry end interface @ %def mci_write_log_entry In order to avoid dependencies on definite MCI implementations, we introduce a MD5 sum calculator. <>= procedure(mci_compute_md5sum), deferred :: compute_md5sum <>= abstract interface subroutine mci_compute_md5sum (mci, pacify) import class(mci_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_compute_md5sum end interface @ %def mci_compute_md5sum @ Record the index of the MCI object within a process. For multi-component processes with more than one integrator, the integrator should know about its own index, so file names can be unique, etc. The default implementation does nothing, however. <>= procedure :: record_index => mci_record_index <>= subroutine mci_record_index (mci, i_mci) class(mci_t), intent(inout) :: mci integer, intent(in) :: i_mci end subroutine mci_record_index @ %def mci_record_index @ There is no Initializer for the abstract type, but a generic setter for the number of channels and dimensions. We make two aliases available, to be able to override it. <>= procedure :: set_dimensions => mci_set_dimensions procedure :: base_set_dimensions => mci_set_dimensions <>= subroutine mci_set_dimensions (mci, n_dim, n_channel) class(mci_t), intent(inout) :: mci integer, intent(in) :: n_dim integer, intent(in) :: n_channel mci%n_dim = n_dim mci%n_channel = n_channel end subroutine mci_set_dimensions @ %def mci_set_dimensions @ Declare particular dimensions as flat. This information can be used to simplify integration. When generating events, the flat dimensions should be sampled with uniform and uncorrelated distribution. It depends on the integrator what to do with that information. <>= procedure (mci_declare_flat_dimensions), deferred :: declare_flat_dimensions <>= abstract interface subroutine mci_declare_flat_dimensions (mci, dim_flat) import class(mci_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_declare_flat_dimensions end interface @ %def mci_declare_flat_dimensions @ Declare particular channels as equivalent, possibly allowing for permutations or reflections of dimensions. We use the information stored in the [[phs_channel_t]] object array that the phase-space module provides. (We do not test this here, deferring the unit test to the [[mci_vamp]] implementation where we actually use this feature.) <>= procedure (mci_declare_equivalences), deferred :: declare_equivalences <>= abstract interface subroutine mci_declare_equivalences (mci, channel, dim_offset) import class(mci_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_declare_equivalences end interface @ %def mci_declare_equivalences @ Declare particular channels as chained together. The implementation may use this array for keeping their weights equal to each other, etc. The chain array is an array sized by the number of channels. For each channel, there is an integer entry that indicates the correponding chains. The total number of chains is the maximum value of this entry. <>= procedure :: declare_chains => mci_declare_chains <>= subroutine mci_declare_chains (mci, chain) class(mci_t), intent(inout) :: mci integer, dimension(:), intent(in) :: chain allocate (mci%chain (size (chain))) mci%n_chain = maxval (chain) allocate (mci%chain_weights (mci%n_chain), source = 0._default) mci%chain = chain end subroutine mci_declare_chains @ %def mci_declare_chains @ Collect channel weights according to chains and store them in the [[chain_weights]] for output. We sum up the weights for all channels that share the same [[chain]] index and store the results in the [[chain_weights]] array. <>= procedure :: collect_chain_weights => mci_collect_chain_weights <>= subroutine mci_collect_chain_weights (mci, weight) class(mci_t), intent(inout) :: mci real(default), dimension(:), intent(in) :: weight integer :: i, c if (allocated (mci%chain)) then mci%chain_weights = 0 do i = 1, size (mci%chain) c = mci%chain(i) mci%chain_weights(c) = mci%chain_weights(c) + weight(i) end do end if end subroutine mci_collect_chain_weights @ %def mci_collect_chain_weights @ Check if there are chains. <>= procedure :: has_chains => mci_has_chains <>= function mci_has_chains (mci) result (flag) class(mci_t), intent(in) :: mci logical :: flag flag = allocated (mci%chain) end function mci_has_chains @ %def mci_has_chains @ Output of the chain weights, kept separate from the main [[write]] method. [The formatting will work as long as the number of chains is less than $10^{10}$\ldots] <>= procedure :: write_chain_weights => mci_write_chain_weights <>= subroutine mci_write_chain_weights (mci, unit) class(mci_t), intent(in) :: mci integer, intent(in), optional :: unit integer :: u, i, n, n_digits character(4) :: ifmt u = given_output_unit (unit) if (allocated (mci%chain_weights)) then write (u, "(1x,A)") "Weights of channel chains (groves):" n_digits = 0 n = size (mci%chain_weights) do while (n > 0) n = n / 10 n_digits = n_digits + 1 end do write (ifmt, "(A1,I1)") "I", n_digits do i = 1, size (mci%chain_weights) write (u, "(3x," // ifmt // ",F13.10)") i, mci%chain_weights(i) end do end if end subroutine mci_write_chain_weights @ %def mci_write_chain_weights @ Set the MD5 sum, independent of initialization. <>= procedure :: set_md5sum => mci_set_md5sum <>= subroutine mci_set_md5sum (mci, md5sum) class(mci_t), intent(inout) :: mci character(32), intent(in) :: md5sum mci%md5sum = md5sum end subroutine mci_set_md5sum @ %def mci_set_md5sum @ Initialize a new integration pass. This is not necessarily meaningful, so we provide an empty base method. The [[mci_vamp]] implementation overrides this. <>= procedure :: add_pass => mci_add_pass <>= subroutine mci_add_pass (mci, adapt_grids, adapt_weights, final_pass) class(mci_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final_pass end subroutine mci_add_pass @ %def mci_add_pass @ Allocate an instance with matching type. This must be deferred. <>= procedure (mci_allocate_instance), deferred :: allocate_instance <>= abstract interface subroutine mci_allocate_instance (mci, mci_instance) import class(mci_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance end subroutine mci_allocate_instance end interface @ %def mci_allocate_instance @ Import a random-number generator. We transfer the allocation of an existing generator state into the object. The generator state may already be initialized, or we can reset it by its [[init]] method. <>= procedure :: import_rng => mci_import_rng <>= subroutine mci_import_rng (mci, rng) class(mci_t), intent(inout) :: mci class(rng_t), intent(inout), allocatable :: rng call move_alloc (rng, mci%rng) end subroutine mci_import_rng @ %def mci_import_rng @ Activate or deactivate the timer. <>= procedure :: set_timer => mci_set_timer <>= subroutine mci_set_timer (mci, active) class(mci_t), intent(inout) :: mci logical, intent(in) :: active mci%use_timer = active end subroutine mci_set_timer @ %def mci_set_timer @ Start and stop signal for the timer, if active. The elapsed time can then be retrieved from the MCI record. <>= procedure :: start_timer => mci_start_timer procedure :: stop_timer => mci_stop_timer <>= subroutine mci_start_timer (mci) class(mci_t), intent(inout) :: mci if (mci%use_timer) call mci%timer%start () end subroutine mci_start_timer subroutine mci_stop_timer (mci) class(mci_t), intent(inout) :: mci if (mci%use_timer) call mci%timer%stop () end subroutine mci_stop_timer @ %def mci_start_timer @ %def mci_stop_timer @ Sampler test. Evaluate the sampler a given number of times. Results are discarded, so we don't need the MCI instance which would record them. The evaluation channel is iterated, and the [[x]] parameters are randomly chosen. <>= procedure :: sampler_test => mci_sampler_test <>= subroutine mci_sampler_test (mci, sampler, n_calls) class(mci_t), intent(inout) :: mci class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_calls real(default), dimension(:), allocatable :: x_in, f real(default), dimension(:,:), allocatable :: x_out real(default) :: val integer :: i, c allocate (x_in (mci%n_dim)) allocate (f (mci%n_channel)) allocate (x_out (mci%n_dim, mci%n_channel)) do i = 1, n_calls c = mod (i, mci%n_channel) + 1 call mci%rng%generate_array (x_in) call sampler%evaluate (c, x_in, val, x_out, f) end do end subroutine mci_sampler_test @ %def mci_sampler_test @ Integrate: this depends on the implementation. We foresee a pacify flag to take care of small numerical noise on different platforms. <>= procedure (mci_integrate), deferred :: integrate <>= abstract interface subroutine mci_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) import class(mci_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results end subroutine mci_integrate end interface @ %def mci_integrate @ Event generation. Depending on the implementation, event generation may or may not require a previous integration pass. Instead of a black-box [[simulate]] method, we require an initializer, a finalizer, and procedures for generating a single event. This allows us to interface simulation event by event from the outside, and it facilitates the further processing of an event after successful generation. For integration, this is not necessary. The initializer has [[intent(inout)]] for the [[mci]] passed object. The reason is that the initializer can read integration results and grids from file, where the results can modify the [[mci]] record. <>= procedure (mci_prepare_simulation), deferred :: prepare_simulation @ %def mci_final_simulation <>= abstract interface subroutine mci_prepare_simulation (mci) import class(mci_t), intent(inout) :: mci end subroutine mci_prepare_simulation end interface @ %def mci_prepare_simulation @ The generated event will reside in in the [[instance]] object (overall results and weight) and in the [[sampler]] object (detailed data). In the real application, we can subsequently call methods of the [[sampler]] in order to further process the generated event. The [[target]] attributes are required by the VAMP implementation, which uses pointers to refer to the instance and sampler objects from within the integration function. <>= procedure (mci_generate), deferred :: generate_weighted_event procedure (mci_generate), deferred :: generate_unweighted_event @ %def mci_generate_weighted_event @ %def mci_generate_unweighted_event <>= abstract interface subroutine mci_generate (mci, instance, sampler) import class(mci_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler end subroutine mci_generate end interface @ %def mci_generate @ This is analogous, but we rebuild the event from the information stored in [[state]] instead of generating it. Note: currently unused outside of tests, might be deleted later. <>= procedure (mci_rebuild), deferred :: rebuild_event <>= abstract interface subroutine mci_rebuild (mci, instance, sampler, state) import class(mci_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state end subroutine mci_rebuild end interface @ %def mci_rebuild @ Pacify: reduce numerical noise. The base implementation does nothing. <>= procedure :: pacify => mci_pacify <>= subroutine mci_pacify (object, efficiency_reset, error_reset) class(mci_t), intent(inout) :: object logical, intent(in), optional :: efficiency_reset, error_reset end subroutine mci_pacify @ %def mci_pacify @ Return the value of the integral, error, efficiency, and time per call. <>= procedure :: get_integral => mci_get_integral procedure :: get_error => mci_get_error procedure :: get_efficiency => mci_get_efficiency procedure :: get_time => mci_get_time <>= function mci_get_integral (mci) result (integral) class(mci_t), intent(in) :: mci real(default) :: integral if (mci%integral_known) then integral = mci%integral else call msg_bug ("The integral is unknown. This is presumably a" // & "WHIZARD bug.") end if end function mci_get_integral function mci_get_error (mci) result (error) class(mci_t), intent(in) :: mci real(default) :: error if (mci%error_known) then error = mci%error else error = 0 end if end function mci_get_error function mci_get_efficiency (mci) result (efficiency) class(mci_t), intent(in) :: mci real(default) :: efficiency if (mci%efficiency_known) then efficiency = mci%efficiency else efficiency = 0 end if end function mci_get_efficiency function mci_get_time (mci) result (time) class(mci_t), intent(in) :: mci real(default) :: time if (mci%use_timer) then time = mci%timer else time = 0 end if end function mci_get_time @ %def mci_get_integral @ %def mci_get_error @ %def mci_get_efficiency @ %def mci_get_time @ Return the MD5 sum of the configuration. This may be overridden in an extension, to return a different MD5 sum. <>= procedure :: get_md5sum => mci_get_md5sum <>= pure function mci_get_md5sum (mci) result (md5sum) class(mci_t), intent(in) :: mci character(32) :: md5sum md5sum = mci%md5sum end function mci_get_md5sum @ %def mci_get_md5sum @ \subsection{MCI instance} The base type contains an array of channel weights. The value [[mci_weight]] is the combined MCI weight that corresponds to a particular sampling point. For convenience, we also store the [[x]] and Jacobian values for this sampling point. <>= public :: mci_instance_t <>= type, abstract :: mci_instance_t logical :: valid = .false. real(default), dimension(:), allocatable :: w real(default), dimension(:), allocatable :: f real(default), dimension(:,:), allocatable :: x integer :: selected_channel = 0 real(default) :: mci_weight = 0 real(default) :: integrand = 0 logical :: negative_weights = .false. integer :: n_dropped = 0 contains <> end type mci_instance_t @ %def mci_instance_t @ Output: deferred <>= procedure (mci_instance_write), deferred :: write <>= abstract interface subroutine mci_instance_write (object, unit, pacify) import class(mci_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify end subroutine mci_instance_write end interface @ %def mci_instance_write @ A finalizer, just in case. <>= procedure (mci_instance_final), deferred :: final <>= abstract interface subroutine mci_instance_final (object) import class(mci_instance_t), intent(inout) :: object end subroutine mci_instance_final end interface @ %def mci_instance_final @ Init: basic initializer for the arrays, otherwise deferred. Assigning the [[mci]] object is also deferred, because it depends on the concrete type. The weights are initialized with an uniform normalized value. <>= procedure (mci_instance_base_init), deferred :: init procedure :: base_init => mci_instance_base_init <>= subroutine mci_instance_base_init (mci_instance, mci) class(mci_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci allocate (mci_instance%w (mci%n_channel)) allocate (mci_instance%f (mci%n_channel)) allocate (mci_instance%x (mci%n_dim, mci%n_channel)) if (mci%n_channel > 0) then call mci_instance%set_channel_weights & (spread (1._default, dim=1, ncopies=mci%n_channel)) end if mci_instance%f = 0 mci_instance%x = 0 end subroutine mci_instance_base_init @ %def mci_instance_base_init @ Explicitly set the array of channel weights. <>= procedure :: set_channel_weights => mci_instance_set_channel_weights <>= subroutine mci_instance_set_channel_weights (mci_instance, weights, sum_non_zero) class(mci_instance_t), intent(inout) :: mci_instance real(default), dimension(:), intent(in) :: weights logical, intent(out), optional :: sum_non_zero real(default) :: wsum wsum = sum (weights) if (wsum /= 0) then mci_instance%w = weights / wsum if (present (sum_non_zero)) sum_non_zero = .true. else if (present (sum_non_zero)) sum_non_zero = .false. call msg_warning ("MC sampler initialization:& & sum of channel weights is zero") end if end subroutine mci_instance_set_channel_weights @ %def mci_instance_set_channel_weights @ Compute the overall weight factor for a configuration of $x$ values and Jacobians $f$. The $x$ values come in [[n_channel]] rows with [[n_dim]] entries each. The $f$ factors constitute an array with [[n_channel]] entries. We assume that the $x$ and $f$ arrays are already stored inside the MC instance. The result is also stored there. <>= procedure (mci_instance_compute_weight), deferred :: compute_weight <>= abstract interface subroutine mci_instance_compute_weight (mci, c) import class(mci_instance_t), intent(inout) :: mci integer, intent(in) :: c end subroutine mci_instance_compute_weight end interface @ %def mci_instance_compute_weight @ Record the integrand as returned by the sampler. Depending on the implementation, this may merely copy the value, or do more complicated things. We may need the MCI weight for the actual computations, so this should be called after the previous routine. <>= procedure (mci_instance_record_integrand), deferred :: record_integrand <>= abstract interface subroutine mci_instance_record_integrand (mci, integrand) import class(mci_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand end subroutine mci_instance_record_integrand end interface @ %def mci_instance_record_integrand @ Sample a point directly: evaluate the sampler, then compute the weight and the weighted integrand. Finally, record the integrand within the MCI instance. If a signal (interrupt) was raised recently, we abort the calculation before entering the sampler. Thus, a previous calculation will have completed and any data are already recorded, but any new point can be discarded. If the [[abort]] flag is present, we may delay the interrupt, so we can do some cleanup. <>= procedure :: evaluate => mci_instance_evaluate <>= subroutine mci_instance_evaluate (mci, sampler, c, x) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x real(default) :: val call sampler%evaluate (c, x, val, mci%x, mci%f) mci%valid = sampler%is_valid () if (mci%valid) then call mci%compute_weight (c) call mci%record_integrand (val) end if end subroutine mci_instance_evaluate @ %def mci_instance_evaluate @ Initiate and terminate simulation. In contrast to integration, we implement these as methods of the process instance, since the [[mci]] configuration object is unchanged. The safety factor reduces the acceptance probability for unweighted events. The implementation of this feature depends on the concrete type. <>= procedure (mci_instance_init_simulation), deferred :: init_simulation procedure (mci_instance_final_simulation), deferred :: final_simulation <>= abstract interface subroutine mci_instance_init_simulation (instance, safety_factor) import class(mci_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_instance_init_simulation end interface abstract interface subroutine mci_instance_final_simulation (instance) import class(mci_instance_t), intent(inout) :: instance end subroutine mci_instance_final_simulation end interface @ %def mci_instance_init_simulation mci_instance_final_simulation @ Assuming that the sampler is in a completely defined state, just extract the data that [[evaluate]] would compute. Also record the integrand. <>= procedure :: fetch => mci_instance_fetch <>= subroutine mci_instance_fetch (mci, sampler, c) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(in) :: sampler integer, intent(in) :: c real(default) :: val mci%valid = sampler%is_valid () if (mci%valid) then call sampler%fetch (val, mci%x, mci%f) call mci%compute_weight (c) call mci%record_integrand (val) end if end subroutine mci_instance_fetch @ %def mci_instance_fetch @ The value, i.e., the weighted integrand, is the integrand (which should be taken as-is from the sampler) multiplied by the MCI weight. <>= procedure :: get_value => mci_instance_get_value <>= function mci_instance_get_value (mci) result (value) class(mci_instance_t), intent(in) :: mci real(default) :: value if (mci%valid) then value = mci%integrand * mci%mci_weight else value = 0 end if end function mci_instance_get_value @ %def mci_instance_get_value @ This is an extra routine. By default, the event weight is equal to the value returned by the previous routine. However, if we select a channel for event generation not just based on the channel weights, the event weight has to account for this bias, so the event weight that applies to event generation is different. In that case, we should override the default routine. <>= procedure :: get_event_weight => mci_instance_get_value @ %def mci_instance_get_event_weight @ Excess weight can occur during unweighted event generation, if the assumed maximum value of the integrand is too small. This excess should be normalized in the same way as the event weight above (which for unweighted events becomes unity). <>= procedure (mci_instance_get_event_excess), deferred :: get_event_excess <>= abstract interface function mci_instance_get_event_excess (mci) result (excess) import class(mci_instance_t), intent(in) :: mci real(default) :: excess end function mci_instance_get_event_excess end interface @ %def mci_instance_get_event_excess @ Dropped events (i.e., events with zero weight that are not retained) are counted within the [[mci_instance]] object. <>= procedure :: get_n_event_dropped => mci_instance_get_n_event_dropped procedure :: reset_n_event_dropped => mci_instance_reset_n_event_dropped procedure :: record_event_dropped => mci_instance_record_event_dropped <>= function mci_instance_get_n_event_dropped (mci) result (n_dropped) class(mci_instance_t), intent(in) :: mci integer :: n_dropped n_dropped = mci%n_dropped end function mci_instance_get_n_event_dropped subroutine mci_instance_reset_n_event_dropped (mci) class(mci_instance_t), intent(inout) :: mci mci%n_dropped = 0 end subroutine mci_instance_reset_n_event_dropped subroutine mci_instance_record_event_dropped (mci) class(mci_instance_t), intent(inout) :: mci mci%n_dropped = mci%n_dropped + 1 end subroutine mci_instance_record_event_dropped @ %def mci_instance_get_n_event_dropped @ %def mci_instance_reset_n_event_dropped @ %def mci_instance_record_event_dropped @ \subsection{MCI state} This object can hold the relevant information that allows us to reconstruct the MCI instance without re-evaluating the sampler completely. We store the [[x_in]] MC input parameter set, which coincides with the section of the complete [[x]] array that belongs to a particular channel. We also store the MC function value. When we want to reconstruct the state, we can use the input array to recover the complete [[x]] and [[f]] arrays (i.e., the kinematics), but do not need to recompute the MC function value (the dynamics). The [[mci_state_t]] may be extended, to allow storing/recalling more information. In that case, we would override the type-bound procedures. However, the base type is also a concrete type and self-contained. <>= public :: mci_state_t <>= type :: mci_state_t integer :: selected_channel = 0 real(default), dimension(:), allocatable :: x_in real(default) :: val contains <> end type mci_state_t @ %def mci_state_t @ Output: <>= procedure :: write => mci_state_write <>= subroutine mci_state_write (object, unit) class(mci_state_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "MCI state:" write (u, "(3x,A,I0)") "Channel = ", object%selected_channel write (u, "(3x,A,999(1x,F12.10))") "x (in) =", object%x_in write (u, "(3x,A,ES19.12)") "Integrand = ", object%val end subroutine mci_state_write @ %def mci_state_write @ To store the object, we take the relevant section of the [[x]] array. The channel used for storing data is taken from the [[instance]] object, but it could be arbitrary in principle. <>= procedure :: store => mci_instance_store <>= subroutine mci_instance_store (mci, state) class(mci_instance_t), intent(in) :: mci class(mci_state_t), intent(out) :: state state%selected_channel = mci%selected_channel allocate (state%x_in (size (mci%x, 1))) state%x_in = mci%x(:,mci%selected_channel) state%val = mci%integrand end subroutine mci_instance_store @ %def mci_instance_store @ Recalling the state, we must consult the sampler in order to fully reconstruct the [[x]] and [[f]] arrays. The integrand value is known, and we also give it to the sampler, bypassing evaluation. The final steps are equivalent to the [[evaluate]] method above. <>= procedure :: recall => mci_instance_recall <>= subroutine mci_instance_recall (mci, sampler, state) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state if (size (state%x_in) == size (mci%x, 1) & .and. state%selected_channel <= size (mci%x, 2)) then call sampler%rebuild (state%selected_channel, & state%x_in, state%val, mci%x, mci%f) call mci%compute_weight (state%selected_channel) call mci%record_integrand (state%val) else call msg_fatal ("Recalling event: mismatch in channel or dimension") end if end subroutine mci_instance_recall @ %def mci_instance_recall @ \subsection{MCI sampler} A sampler is an object that implements a multi-channel parameterization of the unit hypercube. Specifically, it is able to compute, given a channel and a set of $x$ MC parameter values, the complete set of $x$ values and associated Jacobian factors $f$ for all channels. Furthermore, the sampler should return a single real value, the integrand, for the given point in the hypercube. It must implement a method [[evaluate]] for performing the above computations. <>= public :: mci_sampler_t <>= type, abstract :: mci_sampler_t contains <> end type mci_sampler_t @ %def mci_sampler_t @ Output, deferred to the implementation. <>= procedure (mci_sampler_write), deferred :: write <>= abstract interface subroutine mci_sampler_write (object, unit, testflag) import class(mci_sampler_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine mci_sampler_write end interface @ %def mci_sampler_write @ The evaluation routine. Input is the channel index [[c]] and the one-dimensional parameter array [[x_in]]. Output are the integrand value [[val]], the two-dimensional parameter array [[x]] and the Jacobian array [[f]]. <>= procedure (mci_sampler_evaluate), deferred :: evaluate <>= abstract interface subroutine mci_sampler_evaluate (sampler, c, x_in, val, x, f) import class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine mci_sampler_evaluate end interface @ %def mci_sampler_evaluate @ Query the validity of the sampling point. Can be called after [[evaluate]]. <>= procedure (mci_sampler_is_valid), deferred :: is_valid <>= abstract interface function mci_sampler_is_valid (sampler) result (valid) import class(mci_sampler_t), intent(in) :: sampler logical :: valid end function mci_sampler_is_valid end interface @ %def mci_sampler_is_valid @ The shortcut. Again, the channel index [[c]] and the parameter array [[x_in]] are input. However, we also provide the integrand value [[val]], and we just require that the complete parameter array [[x]] and Jacobian array [[f]] are recovered. <>= procedure (mci_sampler_rebuild), deferred :: rebuild <>= abstract interface subroutine mci_sampler_rebuild (sampler, c, x_in, val, x, f) import class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine mci_sampler_rebuild end interface @ %def mci_sampler_rebuild @ This routine should extract the important data from a sampler that has been filled by other means. We fetch the integrand value [[val]], the two-dimensional parameter array [[x]] and the Jacobian array [[f]]. <>= procedure (mci_sampler_fetch), deferred :: fetch <>= abstract interface subroutine mci_sampler_fetch (sampler, val, x, f) import class(mci_sampler_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine mci_sampler_fetch end interface @ %def mci_sampler_fetch @ \subsection{Results record} This is an abstract type which allows us to implement callback: each integration results can optionally be recorded to an instance of this object. The actual object may store a new result, average results, etc. It may also display a result on-line or otherwise, whenever the [[record]] method is called. <>= public :: mci_results_t <>= type, abstract :: mci_results_t contains <> end type mci_results_t @ %def mci_results_t @ The output routine is deferred. We provide an extra [[verbose]] flag, which could serve any purpose. <>= procedure (mci_results_write), deferred :: write procedure (mci_results_write_verbose), deferred :: write_verbose <>= abstract interface subroutine mci_results_write (object, unit, suppress) import class(mci_results_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: suppress end subroutine mci_results_write subroutine mci_results_write_verbose (object, unit) import class(mci_results_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine mci_results_write_verbose end interface @ %def mci_results_write @ This is the generic [[record]] method, which can be called directly from the integrator. The [[record_extended]] procedure store additionally the valid calls, positive and negative efficiency. <>= generic :: record => record_simple, record_extended procedure (mci_results_record_simple), deferred :: record_simple procedure (mci_results_record_extended), deferred :: record_extended <>= abstract interface subroutine mci_results_record_simple (object, n_it, & n_calls, integral, error, efficiency, chain_weights, suppress) import class(mci_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress end subroutine mci_results_record_simple subroutine mci_results_record_extended (object, n_it, n_calls,& & n_calls_valid, integral, error, efficiency, efficiency_pos,& & efficiency_neg, chain_weights, suppress) import class(mci_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls integer, intent(in) :: n_calls_valid real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), intent(in) :: efficiency_pos real(default), intent(in) :: efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress end subroutine mci_results_record_extended end interface @ %def mci_results_record @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_base_ut.f90]]>>= <> module mci_base_ut use unit_tests use mci_base_uti <> <> <> contains <> end module mci_base_ut @ %def mci_base_ut @ <<[[mci_base_uti.f90]]>>= <> module mci_base_uti <> use io_units use diagnostics use phs_base use rng_base use mci_base use rng_base_ut, only: rng_test_t <> <> <> <> contains <> end module mci_base_uti @ %def mci_base_ut @ API: driver for the unit tests below. <>= public :: mci_base_test <>= subroutine mci_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_base_test @ %def mci_base_test @ \subsubsection{Test implementation of the configuration type} The concrete type contains the number of requested calls and the integral result, to be determined. The [[max_factor]] entry is set for the actual test integration, where the integrand is not unity but some other constant value. This value should be set here, such that the actual maximum of the integrand is known when vetoing unweighted events. <>= public :: mci_test_t <>= type, extends (mci_t) :: mci_test_t integer :: divisions = 0 integer :: tries = 0 real(default) :: max_factor = 1 contains procedure :: final => mci_test_final procedure :: write => mci_test_write procedure :: startup_message => mci_test_startup_message procedure :: write_log_entry => mci_test_write_log_entry procedure :: compute_md5sum => mci_test_compute_md5sum procedure :: declare_flat_dimensions => mci_test_ignore_flat_dimensions procedure :: declare_equivalences => mci_test_ignore_equivalences procedure :: set_divisions => mci_test_set_divisions procedure :: set_max_factor => mci_test_set_max_factor procedure :: allocate_instance => mci_test_allocate_instance procedure :: integrate => mci_test_integrate procedure :: prepare_simulation => mci_test_ignore_prepare_simulation procedure :: generate_weighted_event => mci_test_generate_weighted_event procedure :: generate_unweighted_event => & mci_test_generate_unweighted_event procedure :: rebuild_event => mci_test_rebuild_event end type mci_test_t @ %def mci_test_t @ Finalizer: base version is sufficient <>= subroutine mci_test_final (object) class(mci_test_t), intent(inout) :: object call object%base_final () end subroutine mci_test_final @ %def mci_test_final @ Output: trivial <>= subroutine mci_test_write (object, unit, pacify, md5sum_version) class(mci_test_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test integrator:" call object%base_write (u, pacify, md5sum_version) if (object%divisions /= 0) then write (u, "(3x,A,I0)") "Number of divisions = ", object%divisions end if if (allocated (object%rng)) call object%rng%write (u) end subroutine mci_test_write @ %def mci_test_write @ Short version. <>= subroutine mci_test_startup_message (mci, unit, n_calls) class(mci_test_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls call mci%base_startup_message (unit = unit, n_calls = n_calls) write (msg_buffer, "(A,1x,I0,1x,A)") & "Integrator: Test:", mci%divisions, "divisions" call msg_message (unit = unit) end subroutine mci_test_startup_message @ %def mci_test_startup_message @ Log entry: nothing. <>= subroutine mci_test_write_log_entry (mci, u) class(mci_test_t), intent(in) :: mci integer, intent(in) :: u end subroutine mci_test_write_log_entry @ %def mci_test_write_log_entry @ Compute MD5 sum: nothing. <>= subroutine mci_test_compute_md5sum (mci, pacify) class(mci_test_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_test_compute_md5sum @ %def mci_test_compute_md5sum @ This is a no-op for the test integrator. <>= subroutine mci_test_ignore_flat_dimensions (mci, dim_flat) class(mci_test_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_test_ignore_flat_dimensions @ %def mci_test_ignore_flat_dimensions @ Ditto. <>= subroutine mci_test_ignore_equivalences (mci, channel, dim_offset) class(mci_test_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_test_ignore_equivalences @ %def mci_test_ignore_equivalences @ Set the number of divisions to a nonzero value. <>= subroutine mci_test_set_divisions (object, divisions) class(mci_test_t), intent(inout) :: object integer, intent(in) :: divisions object%divisions = divisions end subroutine mci_test_set_divisions @ %def mci_test_set_divisions @ Set the maximum factor (default is 1). <>= subroutine mci_test_set_max_factor (object, max_factor) class(mci_test_t), intent(inout) :: object real(default), intent(in) :: max_factor object%max_factor = max_factor end subroutine mci_test_set_max_factor @ %def mci_test_set_max_factor @ Allocate instance with matching type. <>= subroutine mci_test_allocate_instance (mci, mci_instance) class(mci_test_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_test_instance_t :: mci_instance) end subroutine mci_test_allocate_instance @ %def mci_test_allocate_instance @ Integrate: sample at the midpoints of uniform bits and add the results. We implement this for one and for two dimensions. In the latter case, we scan over two channels and multiply with the channel weights. The arguments [[n_it]] and [[n_calls]] are ignored in this implementations. The test integrator does not set error or efficiency, so those will remain undefined. <>= subroutine mci_test_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results real(default), dimension(:), allocatable :: integral real(default), dimension(:), allocatable :: x integer :: i, j, c select type (instance) type is (mci_test_instance_t) allocate (integral (mci%n_channel)) integral = 0 allocate (x (mci%n_dim)) select case (mci%n_dim) case (1) do c = 1, mci%n_channel do i = 1, mci%divisions x(1) = (i - 0.5_default) / mci%divisions call instance%evaluate (sampler, c, x) integral(c) = integral(c) + instance%get_value () end do end do mci%integral = dot_product (instance%w, integral) & / mci%divisions mci%integral_known = .true. case (2) do c = 1, mci%n_channel do i = 1, mci%divisions x(1) = (i - 0.5_default) / mci%divisions do j = 1, mci%divisions x(2) = (j - 0.5_default) / mci%divisions call instance%evaluate (sampler, c, x) integral(c) = integral(c) + instance%get_value () end do end do end do mci%integral = dot_product (instance%w, integral) & / mci%divisions / mci%divisions mci%integral_known = .true. end select if (present (results)) then call results%record (n_it, n_calls, & mci%integral, mci%error, & efficiency = 0._default) end if end select end subroutine mci_test_integrate @ %def mci_test_integrate @ Simulation initializer and finalizer: nothing to do here. <>= subroutine mci_test_ignore_prepare_simulation (mci) class(mci_test_t), intent(inout) :: mci end subroutine mci_test_ignore_prepare_simulation @ %def mci_test_ignore_prepare_simulation @ Event generator. We use mock random numbers for first selecting the channel and then setting the $x$ values. The results reside in the state of [[instance]] and [[sampler]]. <>= subroutine mci_test_generate_weighted_event (mci, instance, sampler) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default) :: r real(default), dimension(:), allocatable :: x integer :: c select type (instance) type is (mci_test_instance_t) allocate (x (mci%n_dim)) select case (mci%n_channel) case (1) c = 1 call mci%rng%generate (x(1)) case (2) call mci%rng%generate (r) if (r < instance%w(1)) then c = 1 else c = 2 end if call mci%rng%generate (x) end select call instance%evaluate (sampler, c, x) end select end subroutine mci_test_generate_weighted_event @ %def mci_test_generate_weighted_event @ For unweighted events, we generate weighted events and apply a simple rejection step to the relative event weight, until an event passes. (This might result in an endless loop if we happen to be in sync with the mock random generator cycle. Therefore, limit the number of tries.) <>= subroutine mci_test_generate_unweighted_event (mci, instance, sampler) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default) :: r integer :: i select type (instance) type is (mci_test_instance_t) mci%tries = 0 do i = 1, 10 call mci%generate_weighted_event (instance, sampler) mci%tries = mci%tries + 1 call mci%rng%generate (r) if (r < instance%rel_value) exit end do end select end subroutine mci_test_generate_unweighted_event @ %def mci_test_generate_unweighted_event @ Here, we rebuild the event from the state without consulting the rng. <>= subroutine mci_test_rebuild_event (mci, instance, sampler, state) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state select type (instance) type is (mci_test_instance_t) call instance%recall (sampler, state) end select end subroutine mci_test_rebuild_event @ %def mci_test_rebuild_event @ \subsubsection{Instance of the test MCI type} This instance type simulates the VAMP approach. We implement the VAMP multi-channel formula, but keep the channel-specific probability functions $g_i$ smooth and fixed. We also keep the weights fixed. The setup is as follows: we have $n$ mappings of the unit hypercube \begin{equation} x = x (x^{(k)}) \qquad \text{where $x=(x_1,\ldots)$}. \end{equation} The Jacobian factors are the determinants \begin{equation} f^{(k)}(x^{(k)}) = \left|\frac{\partial x}{\partial x^{(k)}}\right| \end{equation} We introduce arbitrary probability functions \begin{equation} g^{(k)}(x^{(k)}) \qquad \text{with}\quad \int dx^{(k)} g^{(k)}(x^{(k)}) = 1 \end{equation} and weights \begin{equation} w_k \qquad \text{with}\quad \sum_k w_k = 1 \end{equation} and construct the joint probability function \begin{equation} g(x) = \sum_k w_k\frac{g^{(k)}(x^{(k)}(x))}{f^{(k)}(x^{(k)}(x))} \end{equation} which also satisfies \begin{equation} \int g(x)\,dx = 1. \end{equation} The algorithm implements a resolution of unity as follows \begin{align} 1 &= \int dx = \int\frac{g(x)}{g(x)} dx \nonumber\\ &= \sum w_k \int \frac{g^{(k)}(x^{(k)}(x))}{f^{(k)}(x^{(k)}(x))} \,\frac{dx}{g(x)} \nonumber\\ &= \sum w_k \int g^{(k)}(x^{(k)}) \frac{dx^{(k)}}{g(x(x^{(k)}))} \end{align} where each of the integrals in the sum is evaluated using the channel-specific variables $x^{(k)}$. We provide two examples: (1) trivial with one channel, one dimension, and all functions unity and (2) two channels and two dimensions with \begin{align} x (x^{(1)}) &= (x^{(1)}_1, x^{(1)}_2) \nonumber\\ x (x^{(2)}) &= (x^{(2)}_1{}^2, x^{(2)}_2) \end{align} hence \begin{align} f^{(1)}&\equiv 1, &f^{(2)}(x^{(2)}) &= 2x^{(2)}_1 \end{align} The probability functions are \begin{align} g^{(1)}&\equiv 1, &g^{(2)}(x^{(2)}) = 2 x^{(2)}_2 \end{align} In the concrete implementation of the integrator instance we store values for the channel probabilities $g_i$ and the accumulated probability $g$. We also store the result (product of integrand and MCI weight), the expected maximum for the result in each channel. <>= public :: mci_test_instance_t <>= type, extends (mci_instance_t) :: mci_test_instance_t type(mci_test_t), pointer :: mci => null () real(default) :: g = 0 real(default), dimension(:), allocatable :: gi real(default) :: value = 0 real(default) :: rel_value = 0 real(default), dimension(:), allocatable :: max contains procedure :: write => mci_test_instance_write procedure :: final => mci_test_instance_final procedure :: init => mci_test_instance_init procedure :: compute_weight => mci_test_instance_compute_weight procedure :: record_integrand => mci_test_instance_record_integrand procedure :: init_simulation => mci_test_instance_init_simulation procedure :: final_simulation => mci_test_instance_final_simulation procedure :: get_event_excess => mci_test_instance_get_event_excess end type mci_test_instance_t @ %def mci_test_instance_t @ Output: trivial <>= subroutine mci_test_instance_write (object, unit, pacify) class(mci_test_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u, c u = given_output_unit (unit) write (u, "(1x,A,ES13.7)") "Result value = ", object%value write (u, "(1x,A,ES13.7)") "Rel. weight = ", object%rel_value write (u, "(1x,A,ES13.7)") "Integrand = ", object%integrand write (u, "(1x,A,ES13.7)") "MCI weight = ", object%mci_weight write (u, "(3x,A,I0)") "c = ", object%selected_channel write (u, "(3x,A,ES13.7)") "g = ", object%g write (u, "(1x,A)") "Channel parameters:" do c = 1, object%mci%n_channel write (u, "(1x,I0,A,4(1x,ES13.7))") c, ": w/f/g/m =", & object%w(c), object%f(c), object%gi(c), object%max(c) write (u, "(4x,A,9(1x,F9.7))") "x =", object%x(:,c) end do end subroutine mci_test_instance_write @ %def mci_test_instance_write @ The finalizer is empty. <>= subroutine mci_test_instance_final (object) class(mci_test_instance_t), intent(inout) :: object end subroutine mci_test_instance_final @ %def mci_test_instance_final @ Initializer. We make use of the analytical result that the maximum of the weighted integrand, in each channel, is equal to $1$ (one-dimensional case) and $2$ (two-dimensional case), respectively. <>= subroutine mci_test_instance_init (mci_instance, mci) class(mci_test_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) select type (mci) type is (mci_test_t) mci_instance%mci => mci end select allocate (mci_instance%gi (mci%n_channel)) mci_instance%gi = 0 allocate (mci_instance%max (mci%n_channel)) select case (mci%n_channel) case (1) mci_instance%max = 1._default case (2) mci_instance%max = 2._default end select end subroutine mci_test_instance_init @ %def mci_test_instance_init @ Compute weight: we implement the VAMP multi-channel formula. The channel probabilities [[gi]] are predefined functions. <>= subroutine mci_test_instance_compute_weight (mci, c) class(mci_test_instance_t), intent(inout) :: mci integer, intent(in) :: c integer :: i mci%selected_channel = c select case (mci%mci%n_dim) case (1) mci%gi(1) = 1 case (2) mci%gi(1) = 1 mci%gi(2) = 2 * mci%x(2,2) end select mci%g = 0 do i = 1, mci%mci%n_channel mci%g = mci%g + mci%w(i) * mci%gi(i) / mci%f(i) end do mci%mci_weight = mci%gi(c) / mci%g end subroutine mci_test_instance_compute_weight @ %def mci_test_instance_compute_weight @ Record the integrand. Apply the Jacobian weight to get the absolute value. Divide by the channel maximum and by any overall factor to get the value relative to the maximum. <>= subroutine mci_test_instance_record_integrand (mci, integrand) class(mci_test_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand mci%value = mci%integrand * mci%mci_weight mci%rel_value = mci%value / mci%max(mci%selected_channel) & / mci%mci%max_factor end subroutine mci_test_instance_record_integrand @ %def mci_test_instance_record_integrand @ Nothing to do here. <>= subroutine mci_test_instance_init_simulation (instance, safety_factor) class(mci_test_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_test_instance_init_simulation subroutine mci_test_instance_final_simulation (instance) class(mci_test_instance_t), intent(inout) :: instance end subroutine mci_test_instance_final_simulation @ %def mci_test_instance_init_simulation @ %def mci_test_instance_final_simulation @ Return always zero. <>= function mci_test_instance_get_event_excess (mci) result (excess) class(mci_test_instance_t), intent(in) :: mci real(default) :: excess excess = 0 end function mci_test_instance_get_event_excess @ %def mci_test_instance_get_event_excess @ \subsubsection{Test sampler} The test sampler implements a fixed configuration, either trivial (one-channel, one-dimension), or slightly nontrivial (two-channel, two-dimension). In the second channel, the first parameter is mapped according to $x_1 = x^{(2)}_1{}^2$, so we have $f^{(2)}(x^{(2)}) = 2x^{(2)}_1$. For display purposes, we store the return values inside the object. This is not strictly necessary. <>= type, extends (mci_sampler_t) :: test_sampler_t real(default) :: integrand = 0 integer :: selected_channel = 0 real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f contains procedure :: init => test_sampler_init procedure :: write => test_sampler_write procedure :: compute => test_sampler_compute procedure :: is_valid => test_sampler_is_valid procedure :: evaluate => test_sampler_evaluate procedure :: rebuild => test_sampler_rebuild procedure :: fetch => test_sampler_fetch end type test_sampler_t @ %def test_sampler_t <>= subroutine test_sampler_init (sampler, n) class(test_sampler_t), intent(out) :: sampler integer, intent(in) :: n allocate (sampler%x (n, n)) allocate (sampler%f (n)) end subroutine test_sampler_init @ %def test_sampler_init @ Output <>= subroutine test_sampler_write (object, unit, testflag) class(test_sampler_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, c u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler:" write (u, "(3x,A,ES13.7)") "Integrand = ", object%integrand write (u, "(3x,A,I0)") "Channel = ", object%selected_channel do c = 1, size (object%f) write (u, "(1x,I0,':',1x,A,ES13.7)") c, "f = ", object%f(c) write (u, "(4x,A,9(1x,F9.7))") "x =", object%x(:,c) end do end subroutine test_sampler_write @ %def test_sampler_write @ Compute $x$ and Jacobians, given the input parameter array. This is called both by [[evaluate]] and [[rebuild]]. <>= subroutine test_sampler_compute (sampler, c, x_in) class(test_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in sampler%selected_channel = c select case (size (sampler%f)) case (1) sampler%x(:,1) = x_in sampler%f = 1 case (2) select case (c) case (1) sampler%x(:,1) = x_in sampler%x(1,2) = sqrt (x_in(1)) sampler%x(2,2) = x_in(2) case (2) sampler%x(1,1) = x_in(1) ** 2 sampler%x(2,1) = x_in(2) sampler%x(:,2) = x_in end select sampler%f(1) = 1 sampler%f(2) = 2 * sampler%x(1,2) end select end subroutine test_sampler_compute @ %def test_sampler_kineamtics @ The point is always valid. <>= function test_sampler_is_valid (sampler) result (valid) class(test_sampler_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_is_valid @ %def test_sampler_is_valid @ The integrand is always equal to 1. <>= subroutine test_sampler_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) sampler%integrand = 1 val = sampler%integrand x = sampler%x f = sampler%f end subroutine test_sampler_evaluate @ %def test_sampler_evaluate @ Construct kinematics from the input $x$ array. Set the integrand instead of evaluating it. <>= subroutine test_sampler_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) sampler%integrand = val x = sampler%x f = sampler%f end subroutine test_sampler_rebuild @ %def test_sampler_rebuild @ Recall contents. <>= subroutine test_sampler_fetch (sampler, val, x, f) class(test_sampler_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%integrand x = sampler%x f = sampler%f end subroutine test_sampler_fetch @ %def test_sampler_fetch @ \subsubsection{Test results object} This mock object just stores and displays the current result. <>= type, extends (mci_results_t) :: mci_test_results_t integer :: n_it = 0 integer :: n_calls = 0 real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 contains <> end type mci_test_results_t @ %def mci_test_results_t @ Output. <>= procedure :: write => mci_test_results_write procedure :: write_verbose => mci_test_results_write_verbose <>= subroutine mci_test_results_write (object, unit, suppress) class(mci_test_results_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: suppress integer :: u u = given_output_unit (unit) write (u, "(3x,A,1x,I0)") "Iterations = ", object%n_it write (u, "(3x,A,1x,I0)") "Calls = ", object%n_calls write (u, "(3x,A,1x,F12.10)") "Integral = ", object%integral write (u, "(3x,A,1x,F12.10)") "Error = ", object%error write (u, "(3x,A,1x,F12.10)") "Efficiency = ", object%efficiency end subroutine mci_test_results_write subroutine mci_test_results_write_verbose (object, unit) class(mci_test_results_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A,1x,I0)") "Iterations = ", object%n_it write (u, "(3x,A,1x,I0)") "Calls = ", object%n_calls write (u, "(3x,A,1x,F12.10)") "Integral = ", object%integral write (u, "(3x,A,1x,F12.10)") "Error = ", object%error write (u, "(3x,A,1x,F12.10)") "Efficiency = ", object%efficiency end subroutine mci_test_results_write_verbose @ %def mci_test_results_write @ Record result. <>= procedure :: record_simple => mci_test_results_record_simple procedure :: record_extended => mci_test_results_record_extended <>= subroutine mci_test_results_record_simple (object, n_it, n_calls, & integral, error, efficiency, chain_weights, suppress) class(mci_test_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress object%n_it = n_it object%n_calls = n_calls object%integral = integral object%error = error object%efficiency = efficiency end subroutine mci_test_results_record_simple subroutine mci_test_results_record_extended (object, n_it, n_calls, & & n_calls_valid, integral, error, efficiency, efficiency_pos, & & efficiency_neg, chain_weights, suppress) class(mci_test_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls integer, intent(in) :: n_calls_valid real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), intent(in) :: efficiency_pos real(default), intent(in) :: efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress object%n_it = n_it object%n_calls = n_calls object%integral = integral object%error = error object%efficiency = efficiency end subroutine mci_test_results_record_extended @ %def mci_test_results_record @ \subsubsection{Integrator configuration data} Construct and display a test integrator configuration object. <>= call test (mci_base_1, "mci_base_1", & "integrator configuration", & u, results) <>= public :: mci_base_1 <>= subroutine mci_base_1 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler real(default) :: integrand write (u, "(A)") "* Test output: mci_base_1" write (u, "(A)") "* Purpose: initialize and display & &test integrator" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select write (u, "(A)") "* Evaluate sampler for given point and channel" write (u, "(A)") call sampler%evaluate (1, [0.25_default, 0.8_default], & integrand, mci_instance%x, mci_instance%f) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Compute MCI weight" write (u, "(A)") call mci_instance%compute_weight (1) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Get integrand and compute weight for another point" write (u, "(A)") call mci_instance%evaluate (sampler, 2, [0.5_default, 0.6_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Recall results, again" write (u, "(A)") call mci_instance%final () deallocate (mci_instance) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci_instance%fetch (sampler, 2) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Retrieve value" write (u, "(A)") write (u, "(1x,A,ES13.7)") "Weighted integrand = ", & mci_instance%get_value () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_1" end subroutine mci_base_1 @ %def mci_base_1 @ \subsubsection{Trivial integral} Use the MCI approach to compute a trivial one-dimensional integral. <>= call test (mci_base_2, "mci_base_2", & "integration", & u, results) <>= public :: mci_base_2 <>= subroutine mci_base_2 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_base_2" write (u, "(A)") "* Purpose: perform a test integral" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (1) end select write (u, "(A)") "* Integrate" write (u, "(A)") call mci%integrate (mci_instance, sampler, 0, 0) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_2" end subroutine mci_base_2 @ %def mci_base_2 @ \subsubsection{Nontrivial integral} Use the MCI approach to compute a simple two-dimensional integral with two channels. <>= call test (mci_base_3, "mci_base_3", & "integration (two channels)", & u, results) <>= public :: mci_base_3 <>= subroutine mci_base_3 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_base_3" write (u, "(A)") "* Purpose: perform a nontrivial test integral" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select write (u, "(A)") "* Integrate" write (u, "(A)") call mci%integrate (mci_instance, sampler, 0, 0) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with higher resolution" write (u, "(A)") select type (mci) type is (mci_test_t) call mci%set_divisions (100) end select call mci%integrate (mci_instance, sampler, 0, 0) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_3" end subroutine mci_base_3 @ %def mci_base_3 @ \subsubsection{Event generation} We generate ``random'' events, one weighted and one unweighted. The test implementation does not require an integration pass, we can generate events immediately. <>= call test (mci_base_4, "mci_base_4", & "event generation (two channels)", & u, results) <>= public :: mci_base_4 <>= subroutine mci_base_4 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_base_4" write (u, "(A)") "* Purpose: generate events" write (u, "(A)") write (u, "(A)") "* Initialize integrator, instance, sampler" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select allocate (rng_test_t :: rng) call mci%import_rng (rng) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call sampler%write (u) write (u, *) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci%generate_unweighted_event (mci_instance, sampler) select type (mci) type is (mci_test_t) write (u, "(A,I0)") " Success in try ", mci%tries write (u, "(A)") end select call sampler%write (u) write (u, *) call mci_instance%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_4" end subroutine mci_base_4 @ %def mci_base_4 @ \subsubsection{Store and recall data} We generate an event and store the relevant data, i.e., the input parameters and the result value for a particular channel. Then we use those data to recover the event, as far as the MCI record is concerned. <>= call test (mci_base_5, "mci_base_5", & "store and recall", & u, results) <>= public :: mci_base_5 <>= subroutine mci_base_5 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng class(mci_state_t), allocatable :: state write (u, "(A)") "* Test output: mci_base_5" write (u, "(A)") "* Purpose: store and recall an event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, instance, sampler" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select allocate (rng_test_t :: rng) call mci%import_rng (rng) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call sampler%write (u) write (u, *) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Store data" write (u, "(A)") allocate (state) call mci_instance%store (state) call mci_instance%final () deallocate (mci_instance) call state%write (u) write (u, "(A)") write (u, "(A)") "* Recall data and rebuild event" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci%rebuild_event (mci_instance, sampler, state) call sampler%write (u) write (u, *) call mci_instance%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_5" end subroutine mci_base_5 @ %def mci_base_5 @ \subsubsection{Chained channels} Chain channels together. In the base configuration, this just fills entries in an extra array (each channel may belong to a chain). In type implementations, this will be used for grouping equivalent channels by keeping their weights equal. <>= call test (mci_base_6, "mci_base_6", & "chained channels", & u, results) <>= public :: mci_base_6 <>= subroutine mci_base_6 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci write (u, "(A)") "* Test output: mci_base_6" write (u, "(A)") "* Purpose: initialize and display & &test integrator with chains" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (1, 5) write (u, "(A)") "* Introduce chains" write (u, "(A)") call mci%declare_chains ([1, 2, 2, 1, 2]) call mci%write (u) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_6" end subroutine mci_base_6 @ %def mci_base_6 @ \subsubsection{Recording results} Compute a simple two-dimensional integral and record the result. <>= call test (mci_base_7, "mci_base_7", & "recording results", & u, results) <>= public :: mci_base_7 <>= subroutine mci_base_7 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(mci_results_t), allocatable :: results write (u, "(A)") "* Test output: mci_base_7" write (u, "(A)") "* Purpose: perform a nontrivial test integral & &and record results" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select allocate (mci_test_results_t :: results) write (u, "(A)") "* Integrate" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000, results) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Display results" write (u, "(A)") call results%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_7" end subroutine mci_base_7 @ %def mci_base_7 @ \subsubsection{Timer} Simple checks for the embedded timer. <>= call test (mci_base_8, "mci_base_8", & "timer", & u, results) <>= public :: mci_base_8 <>= subroutine mci_base_8 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci real(default) :: dummy write (u, "(A)") "* Test output: mci_base_8" write (u, "(A)") "* Purpose: check timer availability" write (u, "(A)") write (u, "(A)") "* Initialize integrator with timer" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%set_timer (active = .true.) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Start timer" write (u, "(A)") call mci%start_timer () call mci%write (u) write (u, "(A)") write (u, "(A)") "* Stop timer" write (u, "(A)") call mci%stop_timer () write (u, "(A)") " (ok)" write (u, "(A)") write (u, "(A)") "* Readout" write (u, "(A)") dummy = mci%get_time () write (u, "(A)") " (ok)" write (u, "(A)") write (u, "(A)") "* Deactivate timer" write (u, "(A)") call mci%set_timer (active = .false.) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_8" end subroutine mci_base_8 @ %def mci_base_8 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Iterations} This module defines a container for the list of iterations and calls, to be submitted to integration. <<[[iterations.f90]]>>= <> module iterations <> <> use io_units use diagnostics <> <> <> contains <> end module iterations @ %def iterations @ \subsection{The iterations list} Each integration pass has a number of iterations and a number of calls per iteration. The last pass produces the end result; the previous passes are used for adaptation. The flags [[adapt_grid]] and [[adapt_weight]] are used only if [[custom_adaptation]] is set. Otherwise, default settings are used that depend on the integration pass. <>= type :: iterations_spec_t private integer :: n_it = 0 integer :: n_calls = 0 logical :: custom_adaptation = .false. logical :: adapt_grids = .false. logical :: adapt_weights = .false. end type iterations_spec_t @ %def iterations_spec_t @ We build up a list of iterations. <>= public :: iterations_list_t <>= type :: iterations_list_t private integer :: n_pass = 0 type(iterations_spec_t), dimension(:), allocatable :: pass contains <> end type iterations_list_t @ %def iterations_list_t @ Initialize an iterations list. For each pass, we have to specify the number of iterations and calls. We may provide the adaption conventions explicitly, either as character codes or as logicals. For passes where the adaptation conventions are not specified, we use the following default setting: adapt weights and grids for all passes except the last one. <>= procedure :: init => iterations_list_init <>= subroutine iterations_list_init & (it_list, n_it, n_calls, adapt, adapt_code, adapt_grids, adapt_weights) class(iterations_list_t), intent(inout) :: it_list integer, dimension(:), intent(in) :: n_it, n_calls logical, dimension(:), intent(in), optional :: adapt type(string_t), dimension(:), intent(in), optional :: adapt_code logical, dimension(:), intent(in), optional :: adapt_grids, adapt_weights integer :: i it_list%n_pass = size (n_it) if (allocated (it_list%pass)) deallocate (it_list%pass) allocate (it_list%pass (it_list%n_pass)) it_list%pass%n_it = n_it it_list%pass%n_calls = n_calls if (present (adapt)) then it_list%pass%custom_adaptation = adapt do i = 1, it_list%n_pass if (adapt(i)) then if (verify (adapt_code(i), "wg") /= 0) then call msg_error ("iteration specification: " & // "adaptation code letters must be 'w' or 'g'") end if it_list%pass(i)%adapt_grids = scan (adapt_code(i), "g") /= 0 it_list%pass(i)%adapt_weights = scan (adapt_code(i), "w") /= 0 end if end do else if (present (adapt_grids) .and. present (adapt_weights)) then it_list%pass%custom_adaptation = .true. it_list%pass%adapt_grids = adapt_grids it_list%pass%adapt_weights = adapt_weights end if do i = 1, it_list%n_pass - 1 if (.not. it_list%pass(i)%custom_adaptation) then it_list%pass(i)%adapt_grids = .true. it_list%pass(i)%adapt_weights = .true. end if end do end subroutine iterations_list_init @ %def iterations_list_init <>= procedure :: clear => iterations_list_clear <>= subroutine iterations_list_clear (it_list) class(iterations_list_t), intent(inout) :: it_list it_list%n_pass = 0 deallocate (it_list%pass) end subroutine iterations_list_clear @ %def iterations_list_clear @ Write the list of iterations. <>= procedure :: write => iterations_list_write <>= subroutine iterations_list_write (it_list, unit) class(iterations_list_t), intent(in) :: it_list integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(A)") char (it_list%to_string ()) end subroutine iterations_list_write @ %def iterations_list_write @ The output as a single-line string. <>= procedure :: to_string => iterations_list_to_string <>= function iterations_list_to_string (it_list) result (buffer) class(iterations_list_t), intent(in) :: it_list type(string_t) :: buffer character(30) :: ibuf integer :: i buffer = "iterations = " if (it_list%n_pass > 0) then do i = 1, it_list%n_pass if (i > 1) buffer = buffer // ", " write (ibuf, "(I0,':',I0)") & it_list%pass(i)%n_it, it_list%pass(i)%n_calls buffer = buffer // trim (ibuf) if (it_list%pass(i)%custom_adaptation & .or. it_list%pass(i)%adapt_grids & .or. it_list%pass(i)%adapt_weights) then buffer = buffer // ':"' if (it_list%pass(i)%adapt_grids) buffer = buffer // "g" if (it_list%pass(i)%adapt_weights) buffer = buffer // "w" buffer = buffer // '"' end if end do else buffer = buffer // "[undefined]" end if end function iterations_list_to_string @ %def iterations_list_to_string @ \subsection{Tools} Return the total number of passes. <>= procedure :: get_n_pass => iterations_list_get_n_pass <>= function iterations_list_get_n_pass (it_list) result (n_pass) class(iterations_list_t), intent(in) :: it_list integer :: n_pass n_pass = it_list%n_pass end function iterations_list_get_n_pass @ %def iterations_list_get_n_pass @ Return the number of calls for a specific pass. <>= procedure :: get_n_calls => iterations_list_get_n_calls <>= function iterations_list_get_n_calls (it_list, pass) result (n_calls) class(iterations_list_t), intent(in) :: it_list integer :: n_calls integer, intent(in) :: pass if (pass <= it_list%n_pass) then n_calls = it_list%pass(pass)%n_calls else n_calls = 0 end if end function iterations_list_get_n_calls @ %def iterations_list_get_n_calls @ <>= procedure :: set_n_calls => iterations_list_set_n_calls <>= subroutine iterations_list_set_n_calls (it_list, pass, n_calls) class(iterations_list_t), intent(inout) :: it_list integer, intent(in) :: pass, n_calls it_list%pass(pass)%n_calls = n_calls end subroutine iterations_list_set_n_calls @ %def iterations_list_set_n_calls @ Get the adaptation mode (automatic/custom) and, for custom adaptation, the flags for a specific pass. <>= procedure :: adapt_grids => iterations_list_adapt_grids procedure :: adapt_weights => iterations_list_adapt_weights <>= function iterations_list_adapt_grids (it_list, pass) result (flag) logical :: flag class(iterations_list_t), intent(in) :: it_list integer, intent(in) :: pass if (pass <= it_list%n_pass) then flag = it_list%pass(pass)%adapt_grids else flag = .false. end if end function iterations_list_adapt_grids function iterations_list_adapt_weights (it_list, pass) result (flag) logical :: flag class(iterations_list_t), intent(in) :: it_list integer, intent(in) :: pass if (pass <= it_list%n_pass) then flag = it_list%pass(pass)%adapt_weights else flag = .false. end if end function iterations_list_adapt_weights @ %def iterations_list_has_custom_adaptation @ %def iterations_list_adapt_grids @ %def iterations_list_adapt_weights @ Return the total number of iterations / the iterations for a specific pass. <>= procedure :: get_n_it => iterations_list_get_n_it <>= function iterations_list_get_n_it (it_list, pass) result (n_it) class(iterations_list_t), intent(in) :: it_list integer :: n_it integer, intent(in) :: pass if (pass <= it_list%n_pass) then n_it = it_list%pass(pass)%n_it else n_it = 0 end if end function iterations_list_get_n_it @ %def iterations_list_get_n_it @ \subsection{Iteration Multipliers} <>= public :: iteration_multipliers_t <>= type :: iteration_multipliers_t real(default) :: mult_real = 1._default real(default) :: mult_virt = 1._default real(default) :: mult_dglap = 1._default real(default) :: mult_threshold = 1._default integer, dimension(:), allocatable :: n_calls0 end type iteration_multipliers_t @ %def iterations_multipliers @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[iterations_ut.f90]]>>= <> module iterations_ut use unit_tests use iterations_uti <> <> contains <> end module iterations_ut @ %def iterations_ut @ <<[[iterations_uti.f90]]>>= <> module iterations_uti <> use iterations <> <> contains <> end module iterations_uti @ %def iterations_ut @ API: driver for the unit tests below. <>= public :: iterations_test <>= subroutine iterations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine iterations_test @ %def iterations_test @ \subsubsection{Empty list} <>= call test (iterations_1, "iterations_1", & "empty iterations list", & u, results) <>= public :: iterations_1 <>= subroutine iterations_1 (u) integer, intent(in) :: u type(iterations_list_t) :: it_list write (u, "(A)") "* Test output: iterations_1" write (u, "(A)") "* Purpose: display empty iterations list" write (u, "(A)") call it_list%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: iterations_1" end subroutine iterations_1 @ %def iterations_1 @ \subsubsection{Fill list} <>= call test (iterations_2, "iterations_2", & "create iterations list", & u, results) <>= public :: iterations_2 <>= subroutine iterations_2 (u) integer, intent(in) :: u type(iterations_list_t) :: it_list write (u, "(A)") "* Test output: iterations_2" write (u, "(A)") "* Purpose: fill and display iterations list" write (u, "(A)") write (u, "(A)") "* Minimal setup (2 passes)" write (u, "(A)") call it_list%init ([2, 4], [5000, 20000]) call it_list%write (u) call it_list%clear () write (u, "(A)") write (u, "(A)") "* Setup with flags (3 passes)" write (u, "(A)") call it_list%init ([2, 4, 5], [5000, 20000, 400], & [.false., .true., .true.], & [var_str (""), var_str ("g"), var_str ("wg")]) call it_list%write (u) write (u, "(A)") write (u, "(A)") "* Extract data" write (u, "(A)") write (u, "(A,I0)") "n_pass = ", it_list%get_n_pass () write (u, "(A)") write (u, "(A,I0)") "n_calls(2) = ", it_list%get_n_calls (2) write (u, "(A)") write (u, "(A,I0)") "n_it(3) = ", it_list%get_n_it (3) write (u, "(A)") write (u, "(A)") "* Test output end: iterations_2" end subroutine iterations_2 @ %def iterations_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Integration results} We record integration results and errors in a dedicated type. This allows us to do further statistics such as weighted average, chi-squared, grouping by integration passes, etc. Note WHIZARD 2.2.0: This code is taken from the previous [[processes]] module essentially unchanged and converted into a separate module. It lacks an overhaul and, in particular, self-tests. <<[[integration_results.f90]]>>= module integration_results <> <> use io_units use format_utils, only: mp_format, pac_fmt use format_defs, only: FMT_10, FMT_14 + use numeric_utils, only: pacify use diagnostics use md5 use os_interface use mci_base <> <> <> <> <> contains <> end module integration_results @ %def integration_results @ \subsection{Integration results entry} This object collects the results of an integration pass and makes them available to the outside. The results object has to distinguish the process type: We store the process type, the index of the integration pass and the absolute iteration index, the number of iterations contained in this result (for averages), and the integral (cross section or partial width), error estimate, efficiency. For intermediate results, we set a flag if this result is an improvement w.r.t. previous ones. The process type indicates decay or scattering. Dummy entries (skipped iterations) have a process type of [[PRC_UNKNOWN]]. The additional information [[n_calls_valid]], [[efficiency_pos]] and [[efficiency_neg]] are stored, but only used in verbose mode. <>= public :: integration_entry_t <>= type :: integration_entry_t private integer :: process_type = PRC_UNKNOWN integer :: pass = 0 integer :: it = 0 integer :: n_it = 0 integer :: n_calls = 0 integer :: n_calls_valid = 0 logical :: improved = .false. real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 real(default) :: efficiency_pos = 0 real(default) :: efficiency_neg = 0 real(default) :: chi2 = 0 real(default), dimension(:), allocatable :: chain_weights contains <> end type integration_entry_t @ %def integration_result_t @ The possible values of the type indicator: <>= integer, parameter, public :: PRC_UNKNOWN = 0 integer, parameter, public :: PRC_DECAY = 1 integer, parameter, public :: PRC_SCATTERING = 2 @ %def PRC_UNKNOWN PRC_DECAY PRC_SCATTERING @ Initialize with all relevant data. <>= interface integration_entry_t module procedure integration_entry_init end interface integration_entry_t <>= type(integration_entry_t) function integration_entry_init (process_type, pass,& & it, n_it, n_calls, n_calls_valid, improved, integral, error,& & efficiency, efficiency_pos, efficiency_neg, chi2, chain_weights)& & result (entry) integer, intent(in) :: process_type, pass, it, n_it, n_calls, n_calls_valid logical, intent(in) :: improved real(default), intent(in) :: integral, error, efficiency, efficiency_pos, efficiency_neg real(default), intent(in), optional :: chi2 real(default), dimension(:), intent(in), optional :: chain_weights entry%process_type = process_type entry%pass = pass entry%it = it entry%n_it = n_it entry%n_calls = n_calls entry%n_calls_valid = n_calls_valid entry%improved = improved entry%integral = integral entry%error = error entry%efficiency = efficiency entry%efficiency_pos = efficiency_pos entry%efficiency_neg = efficiency_neg if (present (chi2)) entry%chi2 = chi2 if (present (chain_weights)) then allocate (entry%chain_weights (size (chain_weights))) entry%chain_weights = chain_weights end if end function integration_entry_init @ %def integration_entry_init @ Access values, some of them computed on demand: <>= procedure :: get_pass => integration_entry_get_pass procedure :: get_n_calls => integration_entry_get_n_calls procedure :: get_n_calls_valid => integration_entry_get_n_calls_valid procedure :: get_integral => integration_entry_get_integral procedure :: get_error => integration_entry_get_error procedure :: get_rel_error => integration_entry_get_relative_error procedure :: get_accuracy => integration_entry_get_accuracy procedure :: get_efficiency => integration_entry_get_efficiency procedure :: get_efficiency_pos => integration_entry_get_efficiency_pos procedure :: get_efficiency_neg => integration_entry_get_efficiency_neg procedure :: get_chi2 => integration_entry_get_chi2 procedure :: has_improved => integration_entry_has_improved procedure :: get_n_groves => integration_entry_get_n_groves <>= elemental function integration_entry_get_pass (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry n = entry%pass end function integration_entry_get_pass elemental function integration_entry_get_n_calls (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry n = entry%n_calls end function integration_entry_get_n_calls elemental function integration_entry_get_n_calls_valid (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry n = entry%n_calls_valid end function integration_entry_get_n_calls_valid elemental function integration_entry_get_integral (entry) result (int) real(default) :: int class(integration_entry_t), intent(in) :: entry int = entry%integral end function integration_entry_get_integral elemental function integration_entry_get_error (entry) result (err) real(default) :: err class(integration_entry_t), intent(in) :: entry err = entry%error end function integration_entry_get_error elemental function integration_entry_get_relative_error (entry) result (err) real(default) :: err class(integration_entry_t), intent(in) :: entry err = 0 if (entry%integral /= 0) then err = entry%error / entry%integral end if end function integration_entry_get_relative_error elemental function integration_entry_get_accuracy (entry) result (acc) real(default) :: acc class(integration_entry_t), intent(in) :: entry acc = accuracy (entry%integral, entry%error, entry%n_calls) end function integration_entry_get_accuracy elemental function accuracy (integral, error, n_calls) result (acc) real(default) :: acc real(default), intent(in) :: integral, error integer, intent(in) :: n_calls acc = 0 if (integral /= 0) then acc = error / integral * sqrt (real (n_calls, default)) end if end function accuracy elemental function integration_entry_get_efficiency (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry eff = entry%efficiency end function integration_entry_get_efficiency elemental function integration_entry_get_efficiency_pos (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry eff = entry%efficiency_pos end function integration_entry_get_efficiency_pos elemental function integration_entry_get_efficiency_neg (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry eff = entry%efficiency_neg end function integration_entry_get_efficiency_neg elemental function integration_entry_get_chi2 (entry) result (chi2) real(default) :: chi2 class(integration_entry_t), intent(in) :: entry chi2 = entry%chi2 end function integration_entry_get_chi2 elemental function integration_entry_has_improved (entry) result (flag) logical :: flag class(integration_entry_t), intent(in) :: entry flag = entry%improved end function integration_entry_has_improved elemental function integration_entry_get_n_groves (entry) result (n_groves) integer :: n_groves class(integration_entry_t), intent(in) :: entry n_groves = 0 if (allocated (entry%chain_weights)) then n_groves = size (entry%chain_weights, 1) end if end function integration_entry_get_n_groves @ %def integration_entry_get_pass @ %def integration_entry_get_integral @ %def integration_entry_get_error @ %def integration_entry_get_relative_error @ %def integration_entry_get_accuracy @ %def accuracy @ %def integration_entry_get_efficiency @ %def integration_entry_get_chi2 @ %def integration_entry_has_improved @ %def integration_entry_get_n_groves @ This writes the standard result account into one screen line. The verbose version uses multiple lines and prints the unabridged values. Dummy entries are not written. <>= procedure :: write => integration_entry_write procedure :: write_verbose => integration_entry_write_verbose <>= subroutine integration_entry_write (entry, unit, verbosity, suppress) class(integration_entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer, intent(in), optional :: verbosity logical, intent(in), optional :: suppress integer :: u character(1) :: star character(12) :: fmt character(7) :: fmt2 character(120) :: buffer integer :: verb logical :: supp u = given_output_unit (unit); if (u < 0) return verb = 0; if (present (verbosity)) verb = verbosity supp = .false.; if (present (suppress)) supp = suppress if (entry%process_type /= PRC_UNKNOWN) then if (entry%improved .and. .not. supp) then star = "*" else star = " " end if call pac_fmt (fmt, FMT_14, "3x," // FMT_10 // ",1x", suppress) call pac_fmt (fmt2, "1x,F6.2", "2x,F5.1", suppress) write (buffer, "(1x,I3,1x,I10)") entry%it, entry%n_calls if (verb > 1) then write (buffer, "(A,1x,I10)") trim (buffer), entry%n_calls_valid end if write (buffer, "(A,1x," // fmt // ",1x,ES9.2,1x,F7.2," // & "1x,F7.2,A1," // fmt2 // ")") & trim (buffer), & entry%integral, & abs(entry%error), & abs(integration_entry_get_relative_error (entry)) * 100, & abs(integration_entry_get_accuracy (entry)), & star, & entry%efficiency * 100 if (verb > 2) then write (buffer, "(A,1X," // fmt2 // ",1X," // fmt2 // ")") & trim (buffer), & entry%efficiency_pos * 100, & entry%efficiency_neg * 100 end if if (entry%n_it /= 1) then write (buffer, "(A,1x,F7.2,1x,I3)") & trim (buffer), & entry%chi2, & entry%n_it end if write (u, "(A)") trim (buffer) end if flush (u) end subroutine integration_entry_write subroutine integration_entry_write_verbose (entry, unit) class(integration_entry_t), intent(in) :: entry integer, intent(in) :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, *) " process_type = ", entry%process_type write (u, *) " pass = ", entry%pass write (u, *) " it = ", entry%it write (u, *) " n_it = ", entry%n_it write (u, *) " n_calls = ", entry%n_calls write (u, *) " n_calls_valid = ", entry%n_calls_valid write (u, *) " improved = ", entry%improved write (u, *) " integral = ", entry%integral write (u, *) " error = ", entry%error write (u, *) " efficiency = ", entry%efficiency write (u, *) "efficiency_pos = ", entry%efficiency_pos write (u, *) "efficiency_neg = ", entry%efficiency_neg write (u, *) " chi2 = ", entry%chi2 if (allocated (entry%chain_weights)) then write (u, *) " n_groves = ", size (entry%chain_weights) write (u, *) "chain_weights = ", entry%chain_weights else write (u, *) " n_groves = 0" end if flush (u) end subroutine integration_entry_write_verbose @ %def integration_entry_write @ Read the entry, assuming it has been written in verbose format. <>= procedure :: read => integration_entry_read <>= subroutine integration_entry_read (entry, unit) class(integration_entry_t), intent(out) :: entry integer, intent(in) :: unit character(30) :: dummy character :: equals integer :: n_groves read (unit, *) dummy, equals, entry%process_type read (unit, *) dummy, equals, entry%pass read (unit, *) dummy, equals, entry%it read (unit, *) dummy, equals, entry%n_it read (unit, *) dummy, equals, entry%n_calls read (unit, *) dummy, equals, entry%n_calls_valid read (unit, *) dummy, equals, entry%improved read (unit, *) dummy, equals, entry%integral read (unit, *) dummy, equals, entry%error read (unit, *) dummy, equals, entry%efficiency read (unit, *) dummy, equals, entry%efficiency_pos read (unit, *) dummy, equals, entry%efficiency_neg read (unit, *) dummy, equals, entry%chi2 read (unit, *) dummy, equals, n_groves if (n_groves /= 0) then allocate (entry%chain_weights (n_groves)) read (unit, *) dummy, equals, entry%chain_weights end if end subroutine integration_entry_read @ %def integration_entry_read @ Write an account of the channel weights, accumulated by groves. <>= procedure :: write_chain_weights => integration_entry_write_chain_weights <>= subroutine integration_entry_write_chain_weights (entry, unit) class(integration_entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return if (allocated (entry%chain_weights)) then do i = 1, size (entry%chain_weights) write (u, "(1x,I3)", advance="no") nint (entry%chain_weights(i) * 100) end do write (u, *) end if end subroutine integration_entry_write_chain_weights @ %def integration_entry_write_chain_weights @ \subsection{Combined integration results} We collect a list of results which grows during the execution of the program. This is implemented as an array which grows if necessary; so we can easily compute averages. We implement this as an extension of the [[mci_results_t]] which is defined in [[mci_base]] as an abstract type. We thus decouple the implementation of the integrator from the implementation of the results display, but nevertheless can record intermediate results during integration. This implies that the present extension implements a [[record]] method. <>= public :: integration_results_t <>= type, extends (mci_results_t) :: integration_results_t private integer :: process_type = PRC_UNKNOWN integer :: current_pass = 0 integer :: n_pass = 0 integer :: n_it = 0 logical :: screen = .false. integer :: unit = 0 integer :: verbosity = 0 real(default) :: error_threshold = 0 type(integration_entry_t), dimension(:), allocatable :: entry type(integration_entry_t), dimension(:), allocatable :: average contains <> end type integration_results_t @ %def integration_results_t @ The array is extended in chunks of 10 entries. <>= integer, parameter :: RESULTS_CHUNK_SIZE = 10 @ %def RESULTS_CHUNK_SIZE @ <>= procedure :: init => integration_results_init <>= subroutine integration_results_init (results, process_type) class(integration_results_t), intent(out) :: results integer, intent(in) :: process_type results%process_type = process_type results%n_pass = 0 results%n_it = 0 allocate (results%entry (RESULTS_CHUNK_SIZE)) allocate (results%average (RESULTS_CHUNK_SIZE)) end subroutine integration_results_init @ %def integration_results_init @ Set verbose output of the integration results. In verbose mode, valid calls, negative as positive efficiency will be printed. <>= procedure :: set_verbosity => integration_results_set_verbosity <>= subroutine integration_results_set_verbosity (results, verbosity) class(integration_results_t), intent(inout) :: results integer, intent(in) :: verbosity results%verbosity = verbosity end subroutine integration_results_set_verbosity @ %def integration_results_set_verbose @ Set additional parameters: the [[error_threshold]] declares that any error value (in absolute numbers) smaller than this is to be considered zero. <>= procedure :: set_error_threshold => integration_results_set_error_threshold <>= subroutine integration_results_set_error_threshold (results, error_threshold) class(integration_results_t), intent(inout) :: results real(default), intent(in) :: error_threshold results%error_threshold = error_threshold end subroutine integration_results_set_error_threshold @ %def integration_results_set_error_threshold @ Output (ASCII format). The [[verbose]] format is used for writing the header in grid files. <>= procedure :: write => integration_results_write procedure :: write_verbose => integration_results_write_verbose <>= subroutine integration_results_write (object, unit, suppress) class(integration_results_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: suppress logical :: verb integer :: u, n u = given_output_unit (unit); if (u < 0) return call object%write_dline (unit) if (object%n_it /= 0) then call object%write_header (unit, logfile = .false.) call object%write_dline (unit) do n = 1, object%n_it if (n > 1) then if (object%entry(n)%pass /= object%entry(n-1)%pass) then call object%write_hline (unit) call object%average(object%entry(n-1)%pass)%write ( & & unit, suppress = suppress) call object%write_hline (unit) end if end if call object%entry(n)%write (unit, & suppress = suppress) end do call object%write_hline(unit) call object%average(object%n_pass)%write (unit, suppress = suppress) else call msg_message ("[WHIZARD integration results: empty]", unit) end if call object%write_dline (unit) flush (u) end subroutine integration_results_write subroutine integration_results_write_verbose (object, unit) class(integration_results_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, n u = given_output_unit (unit); if (u < 0) return write (u, *) "begin(integration_results)" write (u, *) " n_pass = ", object%n_pass write (u, *) " n_it = ", object%n_it if (object%n_it > 0) then write (u, *) "begin(integration_pass)" do n = 1, object%n_it if (n > 1) then if (object%entry(n)%pass /= object%entry(n-1)%pass) then write (u, *) "end(integration_pass)" write (u, *) "begin(integration_pass)" end if end if write (u, *) "begin(iteration)" call object%entry(n)%write_verbose (unit) write (u, *) "end(iteration)" end do write (u, *) "end(integration_pass)" end if write (u, *) "end(integration_results)" flush (u) end subroutine integration_results_write_verbose @ %def integration_results_write integration_results_verbose @ Write a concise table of chain weights, i.e., the channel history where channels are collected by chains. <>= procedure :: write_chain_weights => & integration_results_write_chain_weights <>= subroutine integration_results_write_chain_weights (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit integer :: u, i, n u = given_output_unit (unit); if (u < 0) return if (allocated (results%entry(1)%chain_weights) .and. results%n_it /= 0) then call msg_message ("Phase-space chain (grove) weight history: " & // "(numbers in %)", unit) write (u, "(A9)", advance="no") "| chain |" do i = 1, integration_entry_get_n_groves (results%entry(1)) write (u, "(1x,I3)", advance="no") i end do write (u, *) call results%write_dline (unit) do n = 1, results%n_it if (n > 1) then if (results%entry(n)%pass /= results%entry(n-1)%pass) then call results%write_hline (unit) end if end if write (u, "(1x,I6,1x,A1)", advance="no") n, "|" call results%entry(n)%write_chain_weights (unit) end do flush (u) call results%write_dline(unit) end if end subroutine integration_results_write_chain_weights @ %def integration_results_write_chain_weights @ Read the list from file. The file must be written using the [[verbose]] option of the writing routine. <>= procedure :: read => integration_results_read <>= subroutine integration_results_read (results, unit) class(integration_results_t), intent(out) :: results integer, intent(in) :: unit character(80) :: buffer character :: equals integer :: pass, it read (unit, *) buffer if (trim (adjustl (buffer)) /= "begin(integration_results)") then call read_err (); return end if read (unit, *) buffer, equals, results%n_pass read (unit, *) buffer, equals, results%n_it allocate (results%entry (results%n_it + RESULTS_CHUNK_SIZE)) allocate (results%average (results%n_it + RESULTS_CHUNK_SIZE)) it = 0 do pass = 1, results%n_pass read (unit, *) buffer if (trim (adjustl (buffer)) /= "begin(integration_pass)") then call read_err (); return end if READ_ENTRIES: do read (unit, *) buffer if (trim (adjustl (buffer)) /= "begin(iteration)") then exit READ_ENTRIES end if it = it + 1 call results%entry(it)%read (unit) read (unit, *) buffer if (trim (adjustl (buffer)) /= "end(iteration)") then call read_err (); return end if end do READ_ENTRIES if (trim (adjustl (buffer)) /= "end(integration_pass)") then call read_err (); return end if results%average(pass) = compute_average (results%entry, pass) end do read (unit, *) buffer if (trim (adjustl (buffer)) /= "end(integration_results)") then call read_err (); return end if contains subroutine read_err () call msg_fatal ("Reading integration results from file: syntax error") end subroutine read_err end subroutine integration_results_read @ %def integration_results_read @ Auxiliary output. <>= procedure, private :: write_header procedure, private :: write_hline procedure, private :: write_dline <>= subroutine write_header (results, unit, logfile) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit logical, intent(in), optional :: logfile character(5) :: phys_unit integer :: u u = given_output_unit (unit); if (u < 0) return select case (results%process_type) case (PRC_DECAY); phys_unit = "[GeV]" case (PRC_SCATTERING); phys_unit = "[fb] " case default phys_unit = " " end select write (msg_buffer, "(A, A)") & "It Calls" if (results%verbosity > 1) then write (msg_buffer, "(A, A)") trim (msg_buffer), & " Valid" end if write (msg_buffer, "(A, A)") trim (msg_buffer), & " Integral" // phys_unit // & " Error" // phys_unit // & " Err[%] Acc Eff[%]" if (results%verbosity > 2) then write (msg_buffer, "(A, A)") trim (msg_buffer), & " (+)[%] (-)[%]" end if write (msg_buffer, "(A, A)") trim (msg_buffer), & " Chi2 N[It] |" call msg_message (unit=u, logfile=logfile) end subroutine write_header subroutine write_hline (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit integer :: u, len u = given_output_unit (unit); if (u < 0) return len = 77 if (results%verbosity > 1) len = len + 11 if (results%verbosity > 2) len = len + 16 write (u, "(A)") "|" // (repeat ("-", len)) // "|" flush (u) end subroutine write_hline subroutine write_dline (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit integer :: u, len u = given_output_unit (unit); if (u < 0) return len = 77 if (results%verbosity > 1) len = len + 11 if (results%verbosity > 2) len = len + 16 write (u, "(A)") "|" // (repeat ("=", len)) // "|" flush (u) end subroutine write_dline @ %def write_header write_hline write_dline @ During integration, we do not want to print all results at once, but each intermediate result as soon as we get it. Thus, the previous procedure is chopped in pieces. First piece: store the output unit and a flag whether we want to print to standard output as well. Then write the header if the results are still empty, i.e., before integration has started. The second piece writes a single result to the saved output channels. We call this from the [[record]] method, which can be called from the integrator directly. The third piece writes the average result, once a pass has been completed. The fourth piece writes a footer (if any), assuming that this is the final result. <>= procedure :: display_init => integration_results_display_init procedure :: display_current => integration_results_display_current procedure :: display_pass => integration_results_display_pass procedure :: display_final => integration_results_display_final <>= subroutine integration_results_display_init & (results, screen, unit) class(integration_results_t), intent(inout) :: results logical, intent(in) :: screen integer, intent(in), optional :: unit integer :: u if (present (unit)) results%unit = unit u = given_output_unit () results%screen = screen if (results%n_it == 0) then if (results%screen) then call results%write_dline (u) call results%write_header (u, & logfile=.false.) call results%write_dline (u) end if if (results%unit /= 0) then call results%write_dline (results%unit) call results%write_header (results%unit, & logfile=.false.) call results%write_dline (results%unit) end if else if (results%screen) then call results%write_hline (u) end if if (results%unit /= 0) then call results%write_hline (results%unit) end if end if end subroutine integration_results_display_init subroutine integration_results_display_current (results, pacify) class(integration_results_t), intent(in) :: results integer :: u logical, intent(in), optional :: pacify u = given_output_unit () if (results%screen) then call results%entry(results%n_it)%write (u, & verbosity = results%verbosity, suppress = pacify) end if if (results%unit /= 0) then call results%entry(results%n_it)%write ( & results%unit, verbosity = results%verbosity, suppress = pacify) end if end subroutine integration_results_display_current subroutine integration_results_display_pass (results, pacify) class(integration_results_t), intent(in) :: results logical, intent(in), optional :: pacify integer :: u u = given_output_unit () if (results%screen) then call results%write_hline (u) call results%average(results%entry(results%n_it)%pass)%write ( & u, verbosity = results%verbosity, suppress = pacify) end if if (results%unit /= 0) then call results%write_hline (results%unit) call results%average(results%entry(results%n_it)%pass)%write ( & results%unit, verbosity = results%verbosity, suppress = pacify) end if end subroutine integration_results_display_pass subroutine integration_results_display_final (results) class(integration_results_t), intent(inout) :: results integer :: u u = given_output_unit () if (results%screen) then call results%write_dline (u) end if if (results%unit /= 0) then call results%write_dline (results%unit) end if results%screen = .false. results%unit = 0 end subroutine integration_results_display_final @ %def integration_results_display_init @ %def integration_results_display_current @ %def integration_results_display_pass @ Expand the list of entries if the limit has been reached: <>= procedure :: expand => integration_results_expand <>= subroutine integration_results_expand (results) class(integration_results_t), intent(inout) :: results type(integration_entry_t), dimension(:), allocatable :: entry_tmp if (results%n_it == size (results%entry)) then allocate (entry_tmp (results%n_it)) entry_tmp = results%entry deallocate (results%entry) allocate (results%entry (results%n_it + RESULTS_CHUNK_SIZE)) results%entry(:results%n_it) = entry_tmp deallocate (entry_tmp) end if if (results%n_pass == size (results%average)) then allocate (entry_tmp (results%n_pass)) entry_tmp = results%average deallocate (results%average) allocate (results%average (results%n_it + RESULTS_CHUNK_SIZE)) results%average(:results%n_pass) = entry_tmp deallocate (entry_tmp) end if end subroutine integration_results_expand @ %def integration_results_expand @ Increment the [[current_pass]] counter. Must be done before each new integration pass; after integration, the recording method may use the value of this counter to define the entry. <>= procedure :: new_pass => integration_results_new_pass <>= subroutine integration_results_new_pass (results) class(integration_results_t), intent(inout) :: results results%current_pass = results%current_pass + 1 end subroutine integration_results_new_pass @ %def integration_results_new_pass @ Enter results into the results list. For the error value, we may compare them with a given threshold. This guards against numerical noise, if the exact error would be zero. <>= procedure :: append => integration_results_append <>= subroutine integration_results_append (results, & n_it, n_calls, n_calls_valid, & integral, error, efficiency, efficiency_pos, efficiency_neg, & chain_weights) class(integration_results_t), intent(inout) :: results integer, intent(in) :: n_it, n_calls, n_calls_valid real(default), intent(in) :: integral, error, efficiency, efficiency_pos, & & efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights logical :: improved type(integration_entry_t) :: entry real(default) :: err_checked improved = .true. if (results%n_it /= 0) improved = abs(accuracy (integral, error, n_calls)) & < abs(results%entry(results%n_it)%get_accuracy ()) err_checked = 0 if (abs (error) >= results%error_threshold) err_checked = error entry = integration_entry_t ( & results%process_type, results%current_pass, & results%n_it+1, n_it, n_calls, n_calls_valid, improved, & integral, err_checked, efficiency, efficiency_pos, efficiency_neg, & chain_weights=chain_weights) if (results%n_it == 0) then results%n_it = 1 results%n_pass = 1 else call results%expand () if (entry%pass /= results%entry(results%n_it)%pass) & results%n_pass = results%n_pass + 1 results%n_it = results%n_it + 1 end if results%entry(results%n_it) = entry results%average(results%n_pass) = & compute_average (results%entry, entry%pass) end subroutine integration_results_append @ %def integration_results_append @ Record an integration pass executed by an [[mci]] integrator object. There is a tolerance below we treat an error (relative to the integral) as zero. <>= real(default), parameter, public :: INTEGRATION_ERROR_TOLERANCE = 1e-10 @ %def INTEGRATION_ERROR_TOLERANCE @ <>= procedure :: record_simple => integration_results_record_simple <>= subroutine integration_results_record_simple & (object, n_it, n_calls, integral, error, efficiency, & chain_weights, suppress) class(integration_results_t), intent(inout) :: object integer, intent(in) :: n_it, n_calls real(default), intent(in) :: integral, error, efficiency real(default), dimension(:), intent(in), optional :: chain_weights real(default) :: err logical, intent(in), optional :: suppress err = 0._default if (abs (error) >= abs (integral) * INTEGRATION_ERROR_TOLERANCE) then err = error end if call object%append (n_it, n_calls, 0, integral, err, efficiency, 0._default,& & 0._default, chain_weights) call object%display_current (suppress) end subroutine integration_results_record_simple @ %def integration_results_record_simple @ Record extended results from integration pass. <>= procedure :: record_extended => integration_results_record_extended <>= subroutine integration_results_record_extended (object, n_it, n_calls,& & n_calls_valid, integral, error, efficiency, efficiency_pos,& & efficiency_neg, chain_weights, suppress) class(integration_results_t), intent(inout) :: object integer, intent(in) :: n_it, n_calls, n_calls_valid real(default), intent(in) :: integral, error, efficiency, efficiency_pos,& & efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights real(default) :: err logical, intent(in), optional :: suppress err = 0._default if (abs (error) >= abs (integral) * INTEGRATION_ERROR_TOLERANCE) then err = error end if call object%append (n_it, n_calls, n_calls_valid, integral, err, efficiency,& & efficiency_pos, efficiency_neg, chain_weights) call object%display_current (suppress) end subroutine integration_results_record_extended @ %def integration_results_record_extended @ Compute the average for all entries in the specified integration pass. The integrals are weighted w.r.t.\ their individual errors. The quoted error of the result is the expected error, computed from the weighted average of the given individual errors. This should be compared to the actual distribution of the results, from which we also can compute an error estimate if there is more than one iteration. The ratio of the distribution error and the averaged error, is the $\chi^2$ value. All error distributions are assumed Gaussian, of course. The $\chi^2$ value is a partial check for this assumption. If it is significantly greater than unity, there is something wrong with the individual errors. The efficiency returned is the one of the last entry in the integration pass. If any error vanishes, averaging by this algorithm would fail. In this case, we simply average the entries and use the deviations from this average (if any) to estimate the error. <>= type(integration_entry_t) function compute_average (entry, pass) & & result (result) type(integration_entry_t), dimension(:), intent(in) :: entry integer, intent(in) :: pass integer :: i logical, dimension(size(entry)) :: mask real(default), dimension(size(entry)) :: ivar real(default) :: sum_ivar, variance result%process_type = entry(1)%process_type result%pass = pass mask = entry%pass == pass .and. entry%process_type /= PRC_UNKNOWN result%it = maxval (entry%it, mask) result%n_it = count (mask) result%n_calls = sum (entry%n_calls, mask) result%n_calls_valid = sum (entry%n_calls_valid, mask) if (.not. any (mask .and. entry%error == 0)) then where (mask) ivar = 1 / entry%error ** 2 elsewhere ivar = 0 end where sum_ivar = sum (ivar, mask) variance = 0 if (sum_ivar /= 0) then variance = 1 / sum_ivar end if result%integral = sum (entry%integral * ivar, mask) * variance if (result%n_it > 1) then result%chi2 = & sum ((entry%integral - result%integral)**2 * ivar, mask) & / (result%n_it - 1) end if else if (result%n_it /= 0) then result%integral = sum (entry%integral, mask) / result%n_it variance = 0 if (result%n_it > 1) then variance = & sum ((entry%integral - result%integral)**2, mask) & / (result%n_it - 1) if (result%integral /= 0) then if (abs (variance / result%integral) & < 100 * epsilon (1._default)) then variance = 0 end if end if end if result%chi2 = variance / result%n_it end if result%error = sqrt (variance) result%efficiency = entry(last_index (mask))%efficiency result%efficiency_pos = entry(last_index (mask))%efficiency_pos result%efficiency_neg = entry(last_index (mask))%efficiency_neg contains integer function last_index (mask) result (index) logical, dimension(:), intent(in) :: mask integer :: i do i = size (mask), 1, -1 if (mask(i)) exit end do index = i end function last_index end function compute_average @ %def compute_average @ \subsection{Access results} Return true if the results object has entries. <>= procedure :: exist => integration_results_exist <>= function integration_results_exist (results) result (flag) logical :: flag class(integration_results_t), intent(in) :: results flag = results%n_pass > 0 end function integration_results_exist @ %def integration_results_exist @ Retrieve information from the results record. If [[last]] is set and true, take the last iteration. If [[it]] is set instead, take this iteration. If [[pass]] is set, take this average. If none is set, take the final average. If the result would be invalid, the entry is not assigned. Due to default initialization, this returns a null entry. <>= procedure :: get_entry => results_get_entry <>= function results_get_entry (results, last, it, pass) result (entry) class(integration_results_t), intent(in) :: results type(integration_entry_t) :: entry logical, intent(in), optional :: last integer, intent(in), optional :: it, pass if (present (last)) then if (allocated (results%entry) .and. results%n_it > 0) then entry = results%entry(results%n_it) else call error () end if else if (present (it)) then if (allocated (results%entry) .and. it > 0 .and. it <= results%n_it) then entry = results%entry(it) else call error () end if else if (present (pass)) then if (allocated (results%average) & .and. pass > 0 .and. pass <= results%n_pass) then entry = results%average (pass) else call error () end if else if (allocated (results%average) .and. results%n_pass > 0) then entry = results%average (results%n_pass) else call error () end if end if contains subroutine error () call msg_fatal ("Requested integration result is not available") end subroutine error end function results_get_entry @ %def results_get_entry @ The individual procedures. The [[results]] record should have the [[target]] attribute, but only locally within the function. <>= procedure :: get_n_calls => integration_results_get_n_calls procedure :: get_integral => integration_results_get_integral procedure :: get_error => integration_results_get_error procedure :: get_accuracy => integration_results_get_accuracy procedure :: get_chi2 => integration_results_get_chi2 procedure :: get_efficiency => integration_results_get_efficiency <>= function integration_results_get_n_calls (results, last, it, pass) & result (n_calls) class(integration_results_t), intent(in), target :: results integer :: n_calls logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) n_calls = entry%get_n_calls () end function integration_results_get_n_calls function integration_results_get_integral (results, last, it, pass) & result (integral) class(integration_results_t), intent(in), target :: results real(default) :: integral logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) integral = entry%get_integral () end function integration_results_get_integral function integration_results_get_error (results, last, it, pass) & result (error) class(integration_results_t), intent(in), target :: results real(default) :: error logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) error = entry%get_error () end function integration_results_get_error function integration_results_get_accuracy (results, last, it, pass) & result (accuracy) class(integration_results_t), intent(in), target :: results real(default) :: accuracy logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) accuracy = entry%get_accuracy () end function integration_results_get_accuracy function integration_results_get_chi2 (results, last, it, pass) & result (chi2) class(integration_results_t), intent(in), target :: results real(default) :: chi2 logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) chi2 = entry%get_chi2 () end function integration_results_get_chi2 function integration_results_get_efficiency (results, last, it, pass) & result (efficiency) class(integration_results_t), intent(in), target :: results real(default) :: efficiency logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) efficiency = entry%get_efficiency () end function integration_results_get_efficiency @ %def integration_results_get_n_calls @ %def integration_results_get_integral @ %def integration_results_get_error @ %def integration_results_get_accuracy @ %def integration_results_get_chi2 @ %def integration_results_get_efficiency @ Return the last pass index and the index of the last iteration \emph{within} the last pass. The third routine returns the absolute index of the last iteration. <>= function integration_results_get_current_pass (results) result (pass) integer :: pass type(integration_results_t), intent(in) :: results pass = results%n_pass end function integration_results_get_current_pass function integration_results_get_current_it (results) result (it) integer :: it type(integration_results_t), intent(in) :: results it = 0 if (allocated (results%entry)) then it = count (results%entry(1:results%n_it)%pass == results%n_pass) end if end function integration_results_get_current_it function integration_results_get_last_it (results) result (it) integer :: it type(integration_results_t), intent(in) :: results it = results%n_it end function integration_results_get_last_it @ %def integration_results_get_current_pass @ %def integration_results_get_current_it @ %def integration_results_get_last_it @ Return the index of the best iteration (lowest accuracy value) within the current pass. If none qualifies, return zero. <>= function integration_results_get_best_it (results) result (it) integer :: it type(integration_results_t), intent(in) :: results integer :: i real(default) :: acc, acc_best acc_best = -1 it = 0 do i = 1, results%n_it if (results%entry(i)%pass == results%n_pass) then acc = integration_entry_get_accuracy (results%entry(i)) if (acc_best < 0 .or. acc <= acc_best) then acc_best = acc it = i end if end if end do end function integration_results_get_best_it @ %def integration_results_get_best_it @ Compute the MD5 sum by printing everything and checksumming the resulting file. <>= function integration_results_get_md5sum (results) result (md5sum_results) character(32) :: md5sum_results type(integration_results_t), intent(in) :: results integer :: u u = free_unit () open (unit = u, status = "scratch", action = "readwrite") call results%write_verbose (u) rewind (u) md5sum_results = md5sum (u) close (u) end function integration_results_get_md5sum @ %def integration_results_get_md5sum @ This is (ab)used to suppress numerical noise when integrating constant matrix elements. <>= procedure :: pacify => integration_results_pacify <>= subroutine integration_results_pacify (results, efficiency_reset) class(integration_results_t), intent(inout) :: results logical, intent(in), optional :: efficiency_reset integer :: i logical :: reset reset = .false. if (present (efficiency_reset)) reset = efficiency_reset if (allocated (results%entry)) then do i = 1, size (results%entry) call pacify (results%entry(i)%error, & results%entry(i)%integral * 1.E-9_default) if (reset) results%entry(i)%efficiency = 1 end do end if if (allocated (results%average)) then do i = 1, size (results%average) call pacify (results%average(i)%error, & results%average(i)%integral * 1.E-9_default) if (reset) results%average(i)%efficiency = 1 end do end if end subroutine integration_results_pacify @ %def integration_results_pacify @ <>= procedure :: record_correction => integration_results_record_correction <>= subroutine integration_results_record_correction (object, corr, err) class(integration_results_t), intent(inout) :: object real(default), intent(in) :: corr, err integer :: u u = given_output_unit () if (object%screen) then call object%write_hline (u) call msg_message ("NLO Correction: [O(alpha_s+1)/O(alpha_s)]") write(msg_buffer,'(1X,A1,F7.2,A4,F6.2,1X,A3)') '(', corr, ' +- ', err, ') %' call msg_message () end if end subroutine integration_results_record_correction @ %def integration_results_record_correction @ \subsection{Results display} Write a driver file for history visualization. The ratio of $y$ range over $y$ value must not become too small, otherwise we run into an arithmetic overflow in GAMELAN. 2\% appears to be safe. <>= real, parameter, public :: GML_MIN_RANGE_RATIO = 0.02 <>= public :: integration_results_write_driver <>= subroutine integration_results_write_driver (results, filename, eff_reset) type(integration_results_t), intent(inout) :: results type(string_t), intent(in) :: filename logical, intent(in), optional :: eff_reset type(string_t) :: file_tex integer :: unit integer :: n, i, n_pass, pass integer, dimension(:), allocatable :: ipass real(default) :: ymin, ymax, yavg, ydif, y0, y1 real(default), dimension(results%n_it) :: ymin_arr, ymax_arr logical :: reset file_tex = filename // ".tex" unit = free_unit () open (unit=unit, file=char(file_tex), action="write", status="replace") reset = .false.; if (present (eff_reset)) reset = eff_reset n = results%n_it n_pass = results%n_pass allocate (ipass (results%n_pass)) ipass(1) = 0 pass = 2 do i = 1, n-1 if (integration_entry_get_pass (results%entry(i)) & /= integration_entry_get_pass (results%entry(i+1))) then ipass(pass) = i pass = pass + 1 end if end do ymin_arr = integration_entry_get_integral (results%entry(:n)) & - integration_entry_get_error (results%entry(:n)) ymin = minval (ymin_arr) ymax_arr = integration_entry_get_integral (results%entry(:n)) & + integration_entry_get_error (results%entry(:n)) ymax = maxval (ymax_arr) yavg = (ymax + ymin) / 2 ydif = (ymax - ymin) if (ydif * 1.5 > GML_MIN_RANGE_RATIO * yavg) then y0 = yavg - ydif * 0.75 y1 = yavg + ydif * 0.75 else y0 = yavg * (1 - GML_MIN_RANGE_RATIO / 2) y1 = yavg * (1 + GML_MIN_RANGE_RATIO / 2) end if write (unit, "(A)") "\documentclass{article}" write (unit, "(A)") "\usepackage{a4wide}" write (unit, "(A)") "\usepackage{gamelan}" write (unit, "(A)") "\usepackage{amsmath}" write (unit, "(A)") "" write (unit, "(A)") "\begin{document}" write (unit, "(A)") "\begin{gmlfile}" write (unit, "(A)") "\section*{Integration Results Display}" write (unit, "(A)") "" write (unit, "(A)") "Process: \verb|" // char (filename) // "|" write (unit, "(A)") "" write (unit, "(A)") "\vspace*{2\baselineskip}" write (unit, "(A)") "\unitlength 1mm" write (unit, "(A)") "\begin{gmlcode}" write (unit, "(A)") " picture sym; sym = fshape (circle scaled 1mm)();" write (unit, "(A)") " color col.band; col.band = 0.9white;" write (unit, "(A)") " color col.eband; col.eband = 0.98white;" write (unit, "(A)") "\end{gmlcode}" write (unit, "(A)") "\begin{gmlgraph*}(130,180)[history]" write (unit, "(A)") " setup (linear, linear);" write (unit, "(A,I0,A)") " history.n_pass = ", n_pass, ";" write (unit, "(A,I0,A)") " history.n_it = ", n, ";" write (unit, "(A,A,A)") " history.y0 = #""", char (mp_format (y0)), """;" write (unit, "(A,A,A)") " history.y1 = #""", char (mp_format (y1)), """;" write (unit, "(A)") & " graphrange (#0.5, history.y0), (#(n+0.5), history.y1);" do pass = 1, n_pass write (unit, "(A,I0,A,I0,A)") & " history.pass[", pass, "] = ", ipass(pass), ";" write (unit, "(A,I0,A,A,A)") & " history.avg[", pass, "] = #""", & char (mp_format & (integration_entry_get_integral (results%average(pass)))), & """;" write (unit, "(A,I0,A,A,A)") & " history.err[", pass, "] = #""", & char (mp_format & (integration_entry_get_error (results%average(pass)))), & """;" write (unit, "(A,I0,A,A,A)") & " history.chi[", pass, "] = #""", & char (mp_format & (integration_entry_get_chi2 (results%average(pass)))), & """;" end do write (unit, "(A,I0,A,I0,A)") & " history.pass[", n_pass + 1, "] = ", n, ";" write (unit, "(A)") " for i = 1 upto history.n_pass:" write (unit, "(A)") " if history.chi[i] greater one:" write (unit, "(A)") " fill plot (" write (unit, "(A)") & " (#(history.pass[i] +.5), " & // "history.avg[i] minus history.err[i] times history.chi[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), " & // "history.avg[i] minus history.err[i] times history.chi[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), " & // "history.avg[i] plus history.err[i] times history.chi[i])," write (unit, "(A)") & " (#(history.pass[i] +.5), " & // "history.avg[i] plus history.err[i] times history.chi[i])" write (unit, "(A)") " ) withcolor col.eband fi;" write (unit, "(A)") " fill plot (" write (unit, "(A)") & " (#(history.pass[i] +.5), history.avg[i] minus history.err[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), history.avg[i] minus history.err[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), history.avg[i] plus history.err[i])," write (unit, "(A)") & " (#(history.pass[i] +.5), history.avg[i] plus history.err[i])" write (unit, "(A)") " ) withcolor col.band;" write (unit, "(A)") " draw plot (" write (unit, "(A)") & " (#(history.pass[i] +.5), history.avg[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), history.avg[i])" write (unit, "(A)") " ) dashed evenly;" write (unit, "(A)") " endfor" write (unit, "(A)") " for i = 1 upto history.n_pass + 1:" write (unit, "(A)") " draw plot (" write (unit, "(A)") & " (#(history.pass[i]+.5), history.y0)," write (unit, "(A)") & " (#(history.pass[i]+.5), history.y1)" write (unit, "(A)") " ) dashed withdots;" write (unit, "(A)") " endfor" do i = 1, n write (unit, "(A,I0,A,A,A,A,A)") " plot (history) (#", & i, ", #""", & char (mp_format (integration_entry_get_integral (results%entry(i)))),& """) vbar #""", & char (mp_format (integration_entry_get_error (results%entry(i)))), & """;" end do write (unit, "(A)") " draw piecewise from (history) " & // "withsymbol sym;" write (unit, "(A)") " fullgrid.lr (5,20);" write (unit, "(A)") " standardgrid.bt (n);" write (unit, "(A)") " begingmleps ""Whizard-Logo.eps"";" write (unit, "(A)") " base := (120*unitlength,170*unitlength);" write (unit, "(A)") " height := 9.6*unitlength;" write (unit, "(A)") " width := 11.2*unitlength;" write (unit, "(A)") " endgmleps;" write (unit, "(A)") "\end{gmlgraph*}" write (unit, "(A)") "\end{gmlfile}" write (unit, "(A)") "\clearpage" write (unit, "(A)") "\begin{verbatim}" if (reset) then call results%pacify (reset) end if call integration_results_write (results, unit) write (unit, "(A)") "\end{verbatim}" write (unit, "(A)") "\end{document}" close (unit) end subroutine integration_results_write_driver @ %def integration_results_write_driver @ Call \LaTeX\ and Metapost for the history driver file, and convert to PS and PDF. <>= public :: integration_results_compile_driver <>= subroutine integration_results_compile_driver (results, filename, os_data) type(integration_results_t), intent(in) :: results type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data integer :: unit_dev, status type(string_t) :: file_tex, file_dvi, file_ps, file_pdf, file_mp type(string_t) :: setenv_tex, setenv_mp, pipe, pipe_dvi if (.not. os_data%event_analysis) then call msg_warning ("Skipping integration history display " & // "because latex or mpost is not available") return end if file_tex = filename // ".tex" file_dvi = filename // ".dvi" file_ps = filename // ".ps" file_pdf = filename // ".pdf" file_mp = filename // ".mp" call msg_message ("Creating integration history display "& // char (file_ps) // " and " // char (file_pdf)) 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 // " " // & file_tex // pipe, status) if (status /= 0) exit BLOCK if (os_data%gml /= "") then call os_system_call (setenv_mp // os_data%gml // " " // & file_mp // pipe, status) else call msg_error ("Could not use GAMELAN/MetaPOST.") exit BLOCK end if if (status /= 0) exit BLOCK call os_system_call (setenv_tex // os_data%latex // " " // & file_tex // pipe, status) if (status /= 0) exit BLOCK if (os_data%event_analysis_ps) then call os_system_call (os_data%dvips // " " // & file_dvi // pipe_dvi, status) if (status /= 0) exit BLOCK else call msg_warning ("Skipping PostScript generation because dvips " & // "is not available") exit BLOCK end if if (os_data%event_analysis_pdf) then call os_system_call (os_data%ps2pdf // " " // & file_ps, status) if (status /= 0) exit BLOCK else call msg_warning ("Skipping PDF generation because ps2pdf " & // "is not available") exit BLOCK end if exit BLOCK end do BLOCK if (status /= 0) then call msg_error ("Unable to compile integration history display") end if end subroutine integration_results_compile_driver @ %def integration_results_compile_driver @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[integration_results_ut.f90]]>>= <> module integration_results_ut use unit_tests use integration_results_uti <> <> contains <> end module integration_results_ut @ %def integration_results_ut @ <<[[integration_results_uti.f90]]>>= <> module integration_results_uti <> use integration_results <> <> contains <> end module integration_results_uti @ %def integration_results_ut @ API: driver for the unit tests below. <>= public :: integration_results_test <>= subroutine integration_results_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine integration_results_test @ %def integration_results_test @ \subsubsection{Integration entry} <>= call test (integration_results_1, "integration_results_1", & "record single line and write to log", & u, results) <>= public :: integration_results_1 <>= subroutine integration_results_1 (u) integer, intent(in) :: u type(integration_entry_t) :: entry write (u, "(A)") "* Test output: integration_results_1" write (u, "(A)") "* Purpose: record single entry and write to log" write (u, "(A)") write (u, "(A)") "* Write single line output" write (u, "(A)") entry = integration_entry_t ( & & process_type = 1, & & pass = 1, & & it = 1, & & n_it = 10, & & n_calls = 1000, & & n_calls_valid = 500, & & improved = .true., & & integral = 1.0_default, & & error = 0.5_default, & & efficiency = 0.25_default, & & efficiency_pos = 0.22_default, & & efficiency_neg = 0.03_default) call entry%write (u, 3) write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_1" end subroutine integration_results_1 @ %def integration_results_1 @ <>= call test (integration_results_2, "integration_results_2", & "record single result and write to log", & u, results) <>= public :: integration_results_2 <>= subroutine integration_results_2 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_2" write (u, "(A)") "* Purpose: record single result and write to log" write (u, "(A)") write (u, "(A)") "* Write single line output" write (u, "(A)") call results%init (PRC_DECAY) call results%append (1, 250, 0, 1.0_default, 0.5_default, 0.25_default,& & 0._default, 0._default) call results%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_2" end subroutine integration_results_2 @ %def integration_results_2 @ <>= call test (integration_results_3, "integration_results_3", & "initialize display and add/display each entry", & u, results) <>= public :: integration_results_3 <>= subroutine integration_results_3 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_2" write (u, "(A)") "* Purpose: intialize display, record three entries,& & display pass average and finalize display" write (u, "(A)") write (u, "(A)") "* Initialize display and add entry" write (u, "(A)") call results%init (PRC_DECAY) call results%set_verbosity (1) call results%display_init (screen = .false., unit = u) call results%new_pass () call results%record (1, 250, 1.0_default, 0.5_default, 0.25_default) call results%record (1, 250, 1.1_default, 0.5_default, 0.25_default) call results%record (1, 250, 0.9_default, 0.5_default, 0.25_default) write (u, "(A)") write (u, "(A)") "* Display pass" write (u, "(A)") call results%display_pass () write (u, "(A)") write (u, "(A)") "* Finalize displays" write (u, "(A)") call results%display_final () write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_3" end subroutine integration_results_3 @ %def integration_results_3 @ <>= call test (integration_results_4, "integration_results_4", & "record extended results and display", & u, results) <>= public :: integration_results_4 <>= subroutine integration_results_4 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_4" write (u, "(A)") "* Purpose: record extended results and display with verbosity = 2" write (u, "(A)") write (u, "(A)") "* Initialize display and record extended result" write (u, "(A)") call results%init (PRC_DECAY) call results%set_verbosity (2) call results%display_init (screen = .false., unit = u) call results%new_pass () call results%record (1, 250, 150, 1.0_default, 0.5_default, 0.25_default,& & 0.22_default, 0.03_default) call results%record (1, 250, 180, 1.1_default, 0.5_default, 0.25_default,& & 0.23_default, 0.02_default) call results%record (1, 250, 130, 0.9_default, 0.5_default, 0.25_default,& & 0.25_default, 0.00_default) write (u, "(A)") write (u, "(A)") "* Display pass" write (u, "(A)") call results%display_pass () write (u, "(A)") write (u, "(A)") "* Finalize displays" write (u, "(A)") call results%display_final () write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_4" end subroutine integration_results_4 @ %def integration_results_4 @ <>= call test (integration_results_5, "integration_results_5", & "record extended results and display", & u, results) <>= public :: integration_results_5 <>= subroutine integration_results_5 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_5" write (u, "(A)") "* Purpose: record extended results and display with verbosity = 3" write (u, "(A)") write (u, "(A)") "* Initialize display and record extended result" write (u, "(A)") call results%init (PRC_DECAY) call results%set_verbosity (3) call results%display_init (screen = .false., unit = u) call results%new_pass () call results%record (1, 250, 150, 1.0_default, 0.5_default, 0.25_default,& & 0.22_default, 0.03_default) call results%record (1, 250, 180, 1.1_default, 0.5_default, 0.25_default,& & 0.23_default, 0.02_default) call results%record (1, 250, 130, 0.9_default, 0.5_default, 0.25_default,& & 0.25_default, 0.00_default) call results%display_pass () call results%display_final () write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_5" end subroutine integration_results_5 @ %def integration_results_5 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Dummy integrator} This implementation acts as a placeholder for cases where no integration or event generation is required at all. <<[[mci_none.f90]]>>= <> module mci_none <> use io_units, only: given_output_unit use diagnostics, only: msg_message, msg_fatal use phs_base, only: phs_channel_t use mci_base <> <> <> contains <> end module mci_none @ %def mci_none @ \subsection{Integrator} The object contains the methods for integration and event generation. For the actual work and data storage, it spawns an instance object. After an integration pass, we update the [[max]] parameter to indicate the maximum absolute value of the integrand that the integrator encountered. This is required for event generation. <>= public :: mci_none_t <>= type, extends (mci_t) :: mci_none_t contains <> end type mci_none_t @ %def mci_t @ Finalizer: no-op. <>= procedure :: final => mci_none_final <>= subroutine mci_none_final (object) class(mci_none_t), intent(inout) :: object end subroutine mci_none_final @ %def mci_none_final @ Output. <>= procedure :: write => mci_none_write <>= subroutine mci_none_write (object, unit, pacify, md5sum_version) class(mci_none_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Integrator: non-functional dummy" end subroutine mci_none_write @ %def mci_none_write @ Startup message: short version. <>= procedure :: startup_message => mci_none_startup_message <>= subroutine mci_none_startup_message (mci, unit, n_calls) class(mci_none_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls call msg_message ("Integrator: none") end subroutine mci_none_startup_message @ %def mci_none_startup_message @ Log entry: just headline. <>= procedure :: write_log_entry => mci_none_write_log_entry <>= subroutine mci_none_write_log_entry (mci, u) class(mci_none_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is none (no-op)" end subroutine mci_none_write_log_entry @ %def mci_none_write_log_entry @ MD5 sum: nothing. <>= procedure :: compute_md5sum => mci_none_compute_md5sum <>= subroutine mci_none_compute_md5sum (mci, pacify) class(mci_none_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_none_compute_md5sum @ %def mci_none_compute_md5sum @ The number of channels must be one. <>= procedure :: set_dimensions => mci_none_set_dimensions <>= subroutine mci_none_set_dimensions (mci, n_dim, n_channel) class(mci_none_t), intent(inout) :: mci integer, intent(in) :: n_dim integer, intent(in) :: n_channel if (n_channel == 1) then mci%n_channel = n_channel mci%n_dim = n_dim allocate (mci%dim_is_binned (mci%n_dim)) mci%dim_is_binned = .true. mci%n_dim_binned = count (mci%dim_is_binned) allocate (mci%n_bin (mci%n_dim)) mci%n_bin = 0 else call msg_fatal ("Attempt to initialize single-channel integrator & &for multiple channels") end if end subroutine mci_none_set_dimensions @ %def mci_none_set_dimensions @ Required by API. <>= procedure :: declare_flat_dimensions => mci_none_ignore_flat_dimensions <>= subroutine mci_none_ignore_flat_dimensions (mci, dim_flat) class(mci_none_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_none_ignore_flat_dimensions @ %def mci_none_ignore_flat_dimensions @ Required by API. <>= procedure :: declare_equivalences => mci_none_ignore_equivalences <>= subroutine mci_none_ignore_equivalences (mci, channel, dim_offset) class(mci_none_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_none_ignore_equivalences @ %def mci_none_ignore_equivalences @ Allocate instance with matching type. <>= procedure :: allocate_instance => mci_none_allocate_instance <>= subroutine mci_none_allocate_instance (mci, mci_instance) class(mci_none_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_none_instance_t :: mci_instance) end subroutine mci_none_allocate_instance @ %def mci_none_allocate_instance @ Integrate. This must not be called at all. <>= procedure :: integrate => mci_none_integrate <>= subroutine mci_none_integrate (mci, instance, sampler, n_it, n_calls, & results, pacify) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results call msg_fatal ("Integration: attempt to integrate with the 'mci_none' method") end subroutine mci_none_integrate @ %def mci_none_integrate @ Simulation initializer and finalizer: nothing to do here. <>= procedure :: prepare_simulation => mci_none_ignore_prepare_simulation <>= subroutine mci_none_ignore_prepare_simulation (mci) class(mci_none_t), intent(inout) :: mci end subroutine mci_none_ignore_prepare_simulation @ %def mci_none_ignore_prepare_simulation @ Generate events, must not be called. <>= procedure :: generate_weighted_event => mci_none_generate_no_event procedure :: generate_unweighted_event => mci_none_generate_no_event <>= subroutine mci_none_generate_no_event (mci, instance, sampler) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler call msg_fatal ("Integration: attempt to generate event with the 'mci_none' method") end subroutine mci_none_generate_no_event @ %def mci_none_generate_no_event @ Rebuild an event, no-op. <>= procedure :: rebuild_event => mci_none_rebuild_event <>= subroutine mci_none_rebuild_event (mci, instance, sampler, state) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state end subroutine mci_none_rebuild_event @ %def mci_none_rebuild_event @ \subsection{Integrator instance} Covering the case of flat dimensions, we store a complete [[x]] array. This is filled when generating events. <>= public :: mci_none_instance_t <>= type, extends (mci_instance_t) :: mci_none_instance_t contains <> end type mci_none_instance_t @ %def mci_none_instance_t @ Output. <>= procedure :: write => mci_none_instance_write <>= subroutine mci_none_instance_write (object, unit, pacify) class(mci_none_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Integrator instance: non-functional dummy" end subroutine mci_none_instance_write @ %def mci_none_instance_write @ The finalizer is empty. <>= procedure :: final => mci_none_instance_final <>= subroutine mci_none_instance_final (object) class(mci_none_instance_t), intent(inout) :: object end subroutine mci_none_instance_final @ %def mci_none_instance_final @ Initializer, empty. <>= procedure :: init => mci_none_instance_init <>= subroutine mci_none_instance_init (mci_instance, mci) class(mci_none_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci end subroutine mci_none_instance_init @ %def mci_none_instance_init @ Copy the stored extrema of the integrand in the instance record. <>= procedure :: get_max => mci_none_instance_get_max <>= subroutine mci_none_instance_get_max (instance) class(mci_none_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (mci%max_known) then instance%max_known = .true. instance%max = mci%max instance%min = mci%min instance%max_abs = mci%max_abs instance%min_abs = mci%min_abs end if end associate end subroutine mci_none_instance_get_max @ %def mci_none_instance_get_max @ Reverse operations: recall the extrema, but only if they are wider than the extrema already stored in the configuration. Also recalculate the efficiency value. <>= procedure :: set_max => mci_none_instance_set_max <>= subroutine mci_none_instance_set_max (instance) class(mci_none_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (instance%max_known) then if (mci%max_known) then mci%max = max (mci%max, instance%max) mci%min = min (mci%min, instance%min) mci%max_abs = max (mci%max_abs, instance%max_abs) mci%min_abs = min (mci%min_abs, instance%min_abs) else mci%max = instance%max mci%min = instance%min mci%max_abs = instance%max_abs mci%min_abs = instance%min_abs mci%max_known = .true. end if if (mci%max_abs /= 0) then if (mci%integral_neg == 0) then mci%efficiency = mci%integral / mci%max_abs mci%efficiency_known = .true. else if (mci%n_calls /= 0) then mci%efficiency = & (mci%integral_pos - mci%integral_neg) / mci%max_abs mci%efficiency_known = .true. end if end if end if end associate end subroutine mci_none_instance_set_max @ %def mci_none_instance_set_max @ The weight cannot be computed. <>= procedure :: compute_weight => mci_none_instance_compute_weight <>= subroutine mci_none_instance_compute_weight (mci, c) class(mci_none_instance_t), intent(inout) :: mci integer, intent(in) :: c call msg_fatal ("Integration: attempt to compute weight with the 'mci_none' method") end subroutine mci_none_instance_compute_weight @ %def mci_none_instance_compute_weight @ Record the integrand, no-op. <>= procedure :: record_integrand => mci_none_instance_record_integrand <>= subroutine mci_none_instance_record_integrand (mci, integrand) class(mci_none_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand end subroutine mci_none_instance_record_integrand @ %def mci_none_instance_record_integrand @ No-op. <>= procedure :: init_simulation => mci_none_instance_init_simulation procedure :: final_simulation => mci_none_instance_final_simulation <>= subroutine mci_none_instance_init_simulation (instance, safety_factor) class(mci_none_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_none_instance_init_simulation subroutine mci_none_instance_final_simulation (instance) class(mci_none_instance_t), intent(inout) :: instance end subroutine mci_none_instance_final_simulation @ %def mci_none_instance_init_simulation @ %def mci_none_instance_final_simulation @ Return excess weight for the current event: return zero, just in case. <>= procedure :: get_event_excess => mci_none_instance_get_event_excess <>= function mci_none_instance_get_event_excess (mci) result (excess) class(mci_none_instance_t), intent(in) :: mci real(default) :: excess excess = 0 end function mci_none_instance_get_event_excess @ %def mci_none_instance_get_event_excess @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_none_ut.f90]]>>= <> module mci_none_ut use unit_tests use mci_none_uti <> <> contains <> end module mci_none_ut @ %def mci_none_ut @ <<[[mci_none_uti.f90]]>>= <> module mci_none_uti use mci_base use mci_none <> <> <> contains <> end module mci_none_uti @ %def mci_none_ut @ API: driver for the unit tests below. <>= public :: mci_none_test <>= subroutine mci_none_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_none_test @ %def mci_none_test @ \subsubsection{Trivial sanity check} Construct an integrator and display it. <>= call test (mci_none_1, "mci_none_1", & "dummy integrator", & u, results) <>= public :: mci_none_1 <>= subroutine mci_none_1 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_none_1" write (u, "(A)") "* Purpose: display mci configuration" write (u, "(A)") write (u, "(A)") "* Allocate integrator" write (u, "(A)") allocate (mci_none_t :: mci) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci_instance%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_none_1" end subroutine mci_none_1 @ %def mci_none_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Simple midpoint integration} This is a most simple implementation of an integrator. The algorithm is the straightforward multi-dimensional midpoint rule, i.e., the integration hypercube is binned uniformly, the integrand is evaluated at the midpoints of each bin, and the result is the average. The binning is equivalent for all integration dimensions. This rule is accurate to the order $h^2$, where $h$ is the bin width. Given that $h=N^{-1/d}$, where $d$ is the integration dimension and $N$ is the total number of sampling points, we get a relative error of order $N^{-2/d}$. This is superior to MC integration if $d<4$, and equivalent if $d=4$. It is not worse than higher-order formulas (such as Gauss integration) if the integrand is not smooth, e.g., if it contains cuts. The integrator is specifically single-channel. However, we do not limit the dimension. <<[[mci_midpoint.f90]]>>= <> module mci_midpoint <> use io_units use diagnostics use phs_base use mci_base <> <> <> contains <> end module mci_midpoint @ %def mci_midpoint @ \subsection{Integrator} The object contains the methods for integration and event generation. For the actual work and data storage, it spawns an instance object. After an integration pass, we update the [[max]] parameter to indicate the maximum absolute value of the integrand that the integrator encountered. This is required for event generation. <>= public :: mci_midpoint_t <>= type, extends (mci_t) :: mci_midpoint_t integer :: n_dim_binned = 0 logical, dimension(:), allocatable :: dim_is_binned logical :: calls_known = .false. integer :: n_calls = 0 integer :: n_calls_pos = 0 integer :: n_calls_nul = 0 integer :: n_calls_neg = 0 real(default) :: integral_pos = 0 real(default) :: integral_neg = 0 integer, dimension(:), allocatable :: n_bin logical :: max_known = .false. real(default) :: max = 0 real(default) :: min = 0 real(default) :: max_abs = 0 real(default) :: min_abs = 0 contains <> end type mci_midpoint_t @ %def mci_t @ Finalizer: base version is sufficient <>= procedure :: final => mci_midpoint_final <>= subroutine mci_midpoint_final (object) class(mci_midpoint_t), intent(inout) :: object call object%base_final () end subroutine mci_midpoint_final @ %def mci_midpoint_final @ Output. <>= procedure :: write => mci_midpoint_write <>= subroutine mci_midpoint_write (object, unit, pacify, md5sum_version) class(mci_midpoint_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Single-channel midpoint rule integrator:" call object%base_write (u, pacify, md5sum_version) if (object%n_dim_binned < object%n_dim) then write (u, "(3x,A,99(1x,I0))") "Flat dimensions =", & pack ([(i, i = 1, object%n_dim)], mask = .not. object%dim_is_binned) write (u, "(3x,A,I0)") "Number of binned dim = ", object%n_dim_binned end if if (object%calls_known) then write (u, "(3x,A,99(1x,I0))") "Number of bins =", object%n_bin write (u, "(3x,A,I0)") "Number of calls = ", object%n_calls if (object%n_calls_pos /= object%n_calls) then write (u, "(3x,A,I0)") " positive value = ", object%n_calls_pos write (u, "(3x,A,I0)") " zero value = ", object%n_calls_nul write (u, "(3x,A,I0)") " negative value = ", object%n_calls_neg write (u, "(3x,A,ES17.10)") & "Integral (pos. part) = ", object%integral_pos write (u, "(3x,A,ES17.10)") & "Integral (neg. part) = ", object%integral_neg end if end if if (object%max_known) then write (u, "(3x,A,ES17.10)") "Maximum of integrand = ", object%max write (u, "(3x,A,ES17.10)") "Minimum of integrand = ", object%min if (object%min /= object%min_abs) then write (u, "(3x,A,ES17.10)") "Maximum (abs. value) = ", object%max_abs write (u, "(3x,A,ES17.10)") "Minimum (abs. value) = ", object%min_abs end if end if if (allocated (object%rng)) call object%rng%write (u) end subroutine mci_midpoint_write @ %def mci_midpoint_write @ Startup message: short version. <>= procedure :: startup_message => mci_midpoint_startup_message <>= subroutine mci_midpoint_startup_message (mci, unit, n_calls) class(mci_midpoint_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls call mci%base_startup_message (unit = unit, n_calls = n_calls) if (mci%n_dim_binned < mci%n_dim) then write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: Midpoint rule:", & mci%n_dim_binned, "binned dimensions" else write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: Midpoint rule" end if call msg_message (unit = unit) end subroutine mci_midpoint_startup_message @ %def mci_midpoint_startup_message @ Log entry: just headline. <>= procedure :: write_log_entry => mci_midpoint_write_log_entry <>= subroutine mci_midpoint_write_log_entry (mci, u) class(mci_midpoint_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is Midpoint rule" end subroutine mci_midpoint_write_log_entry @ %def mci_midpoint_write_log_entry @ MD5 sum: nothing. <>= procedure :: compute_md5sum => mci_midpoint_compute_md5sum <>= subroutine mci_midpoint_compute_md5sum (mci, pacify) class(mci_midpoint_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_midpoint_compute_md5sum @ %def mci_midpoint_compute_md5sum @ The number of channels must be one. <>= procedure :: set_dimensions => mci_midpoint_set_dimensions <>= subroutine mci_midpoint_set_dimensions (mci, n_dim, n_channel) class(mci_midpoint_t), intent(inout) :: mci integer, intent(in) :: n_dim integer, intent(in) :: n_channel if (n_channel == 1) then mci%n_channel = n_channel mci%n_dim = n_dim allocate (mci%dim_is_binned (mci%n_dim)) mci%dim_is_binned = .true. mci%n_dim_binned = count (mci%dim_is_binned) allocate (mci%n_bin (mci%n_dim)) mci%n_bin = 0 else call msg_fatal ("Attempt to initialize single-channel integrator & &for multiple channels") end if end subroutine mci_midpoint_set_dimensions @ %def mci_midpoint_set_dimensions @ Declare particular dimensions as flat. These dimensions will not be binned. <>= procedure :: declare_flat_dimensions => mci_midpoint_declare_flat_dimensions <>= subroutine mci_midpoint_declare_flat_dimensions (mci, dim_flat) class(mci_midpoint_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat integer :: d mci%n_dim_binned = mci%n_dim - size (dim_flat) do d = 1, size (dim_flat) mci%dim_is_binned(dim_flat(d)) = .false. end do mci%n_dim_binned = count (mci%dim_is_binned) end subroutine mci_midpoint_declare_flat_dimensions @ %def mci_midpoint_declare_flat_dimensions @ Declare particular channels as equivalent. This has no effect. <>= procedure :: declare_equivalences => mci_midpoint_ignore_equivalences <>= subroutine mci_midpoint_ignore_equivalences (mci, channel, dim_offset) class(mci_midpoint_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_midpoint_ignore_equivalences @ %def mci_midpoint_ignore_equivalences @ Allocate instance with matching type. <>= procedure :: allocate_instance => mci_midpoint_allocate_instance <>= subroutine mci_midpoint_allocate_instance (mci, mci_instance) class(mci_midpoint_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_midpoint_instance_t :: mci_instance) end subroutine mci_midpoint_allocate_instance @ %def mci_midpoint_allocate_instance @ Integrate. The number of dimensions is arbitrary. We make sure that the number of calls is evenly distributed among the dimensions. The actual number of calls will typically be smaller than the requested number, but never smaller than 1. The sampling over a variable number of dimensions implies a variable number of nested loops. We implement this by a recursive subroutine, one loop in each recursion level. The number of iterations [[n_it]] is ignored. Also, the error is set to zero in the current implementation. With this integrator, we allow the calculation to abort immediately when forced by a signal. There is no state that we can save, hence we do not catch an interrupt. <>= procedure :: integrate => mci_midpoint_integrate <>= subroutine mci_midpoint_integrate (mci, instance, sampler, n_it, n_calls, & results, pacify) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results real(default), dimension(:), allocatable :: x real(default) :: integral, integral_pos, integral_neg integer :: n_bin select type (instance) type is (mci_midpoint_instance_t) allocate (x (mci%n_dim)) integral = 0 integral_pos = 0 integral_neg = 0 select case (mci%n_dim_binned) case (1) n_bin = n_calls case (2:) n_bin = max (int (n_calls ** (1. / mci%n_dim_binned)), 1) end select where (mci%dim_is_binned) mci%n_bin = n_bin elsewhere mci%n_bin = 1 end where mci%n_calls = product (mci%n_bin) mci%n_calls_pos = 0 mci%n_calls_nul = 0 mci%n_calls_neg = 0 mci%calls_known = .true. call sample_dim (mci%n_dim) mci%integral = integral / mci%n_calls mci%integral_pos = integral_pos / mci%n_calls mci%integral_neg = integral_neg / mci%n_calls mci%integral_known = .true. call instance%set_max () if (present (results)) then call results%record (1, mci%n_calls, & mci%integral, mci%error, mci%efficiency) end if end select contains recursive subroutine sample_dim (d) integer, intent(in) :: d integer :: i real(default) :: value do i = 1, mci%n_bin(d) x(d) = (i - 0.5_default) / mci%n_bin(d) if (d > 1) then call sample_dim (d - 1) else if (signal_is_pending ()) return call instance%evaluate (sampler, 1, x) value = instance%get_value () if (value > 0) then mci%n_calls_pos = mci%n_calls_pos + 1 integral = integral + value integral_pos = integral_pos + value else if (value == 0) then mci%n_calls_nul = mci%n_calls_nul + 1 else mci%n_calls_neg = mci%n_calls_neg + 1 integral = integral + value integral_neg = integral_neg + value end if end if end do end subroutine sample_dim end subroutine mci_midpoint_integrate @ %def mci_midpoint_integrate @ Simulation initializer and finalizer: nothing to do here. <>= procedure :: prepare_simulation => mci_midpoint_ignore_prepare_simulation <>= subroutine mci_midpoint_ignore_prepare_simulation (mci) class(mci_midpoint_t), intent(inout) :: mci end subroutine mci_midpoint_ignore_prepare_simulation @ %def mci_midpoint_ignore_prepare_simulation @ Generate weighted event. <>= procedure :: generate_weighted_event => mci_midpoint_generate_weighted_event <>= subroutine mci_midpoint_generate_weighted_event (mci, instance, sampler) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default), dimension(mci%n_dim) :: x select type (instance) type is (mci_midpoint_instance_t) call mci%rng%generate (x) call instance%evaluate (sampler, 1, x) instance%excess_weight = 0 end select end subroutine mci_midpoint_generate_weighted_event @ %def mci_midpoint_generate_weighted_event @ For unweighted events, we generate weighted events and apply a simple rejection step to the relative event weight, until an event passes. Note that we use the [[max_abs]] value stored in the configuration record, not the one stored in the instance. The latter may change during event generation. After an event generation pass is over, we may update the value for a subsequent pass. <>= procedure :: generate_unweighted_event => & mci_midpoint_generate_unweighted_event <>= subroutine mci_midpoint_generate_unweighted_event (mci, instance, sampler) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default) :: x, norm, int select type (instance) type is (mci_midpoint_instance_t) if (mci%max_known .and. mci%max_abs > 0) then norm = abs (mci%max_abs * instance%safety_factor) REJECTION: do call mci%generate_weighted_event (instance, sampler) if (sampler%is_valid ()) then call mci%rng%generate (x) int = abs (instance%integrand) if (x * norm <= int) then if (norm > 0 .and. norm < int) then instance%excess_weight = int / norm - 1 end if exit REJECTION end if end if if (signal_is_pending ()) return end do REJECTION else call msg_fatal ("Unweighted event generation: & &maximum of integrand is zero or unknown") end if end select end subroutine mci_midpoint_generate_unweighted_event @ %def mci_midpoint_generate_unweighted_event @ Rebuild an event, using the [[state]] input. <>= procedure :: rebuild_event => mci_midpoint_rebuild_event <>= subroutine mci_midpoint_rebuild_event (mci, instance, sampler, state) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state select type (instance) type is (mci_midpoint_instance_t) call instance%recall (sampler, state) end select end subroutine mci_midpoint_rebuild_event @ %def mci_midpoint_rebuild_event @ \subsection{Integrator instance} Covering the case of flat dimensions, we store a complete [[x]] array. This is filled when generating events. <>= public :: mci_midpoint_instance_t <>= type, extends (mci_instance_t) :: mci_midpoint_instance_t type(mci_midpoint_t), pointer :: mci => null () logical :: max_known = .false. real(default) :: max = 0 real(default) :: min = 0 real(default) :: max_abs = 0 real(default) :: min_abs = 0 real(default) :: safety_factor = 1 real(default) :: excess_weight = 0 contains <> end type mci_midpoint_instance_t @ %def mci_midpoint_instance_t @ Output. <>= procedure :: write => mci_midpoint_instance_write <>= subroutine mci_midpoint_instance_write (object, unit, pacify) class(mci_midpoint_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u u = given_output_unit (unit) write (u, "(1x,A,9(1x,F12.10))") "x =", object%x(:,1) write (u, "(1x,A,ES19.12)") "Integrand = ", object%integrand write (u, "(1x,A,ES19.12)") "Weight = ", object%mci_weight if (object%safety_factor /= 1) then write (u, "(1x,A,ES19.12)") "Safety f = ", object%safety_factor end if if (object%excess_weight /= 0) then write (u, "(1x,A,ES19.12)") "Excess = ", object%excess_weight end if if (object%max_known) then write (u, "(1x,A,ES19.12)") "Maximum = ", object%max write (u, "(1x,A,ES19.12)") "Minimum = ", object%min if (object%min /= object%min_abs) then write (u, "(1x,A,ES19.12)") "Max.(abs) = ", object%max_abs write (u, "(1x,A,ES19.12)") "Min.(abs) = ", object%min_abs end if end if end subroutine mci_midpoint_instance_write @ %def mci_midpoint_instance_write @ The finalizer is empty. <>= procedure :: final => mci_midpoint_instance_final <>= subroutine mci_midpoint_instance_final (object) class(mci_midpoint_instance_t), intent(inout) :: object end subroutine mci_midpoint_instance_final @ %def mci_midpoint_instance_final @ Initializer. <>= procedure :: init => mci_midpoint_instance_init <>= subroutine mci_midpoint_instance_init (mci_instance, mci) class(mci_midpoint_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) select type (mci) type is (mci_midpoint_t) mci_instance%mci => mci call mci_instance%get_max () mci_instance%selected_channel = 1 end select end subroutine mci_midpoint_instance_init @ %def mci_midpoint_instance_init @ Copy the stored extrema of the integrand in the instance record. <>= procedure :: get_max => mci_midpoint_instance_get_max <>= subroutine mci_midpoint_instance_get_max (instance) class(mci_midpoint_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (mci%max_known) then instance%max_known = .true. instance%max = mci%max instance%min = mci%min instance%max_abs = mci%max_abs instance%min_abs = mci%min_abs end if end associate end subroutine mci_midpoint_instance_get_max @ %def mci_midpoint_instance_get_max @ Reverse operations: recall the extrema, but only if they are wider than the extrema already stored in the configuration. Also recalculate the efficiency value. <>= procedure :: set_max => mci_midpoint_instance_set_max <>= subroutine mci_midpoint_instance_set_max (instance) class(mci_midpoint_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (instance%max_known) then if (mci%max_known) then mci%max = max (mci%max, instance%max) mci%min = min (mci%min, instance%min) mci%max_abs = max (mci%max_abs, instance%max_abs) mci%min_abs = min (mci%min_abs, instance%min_abs) else mci%max = instance%max mci%min = instance%min mci%max_abs = instance%max_abs mci%min_abs = instance%min_abs mci%max_known = .true. end if if (mci%max_abs /= 0) then if (mci%integral_neg == 0) then mci%efficiency = mci%integral / mci%max_abs mci%efficiency_known = .true. else if (mci%n_calls /= 0) then mci%efficiency = & (mci%integral_pos - mci%integral_neg) / mci%max_abs mci%efficiency_known = .true. end if end if end if end associate end subroutine mci_midpoint_instance_set_max @ %def mci_midpoint_instance_set_max @ The weight is the Jacobian of the mapping for the only channel. <>= procedure :: compute_weight => mci_midpoint_instance_compute_weight <>= subroutine mci_midpoint_instance_compute_weight (mci, c) class(mci_midpoint_instance_t), intent(inout) :: mci integer, intent(in) :: c select case (c) case (1) mci%mci_weight = mci%f(1) case default call msg_fatal ("MCI midpoint integrator: only single channel supported") end select end subroutine mci_midpoint_instance_compute_weight @ %def mci_midpoint_instance_compute_weight @ Record the integrand. Update stored values for maximum and minimum. <>= procedure :: record_integrand => mci_midpoint_instance_record_integrand <>= subroutine mci_midpoint_instance_record_integrand (mci, integrand) class(mci_midpoint_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand if (mci%max_known) then mci%max = max (mci%max, integrand) mci%min = min (mci%min, integrand) mci%max_abs = max (mci%max_abs, abs (integrand)) mci%min_abs = min (mci%min_abs, abs (integrand)) else mci%max = integrand mci%min = integrand mci%max_abs = abs (integrand) mci%min_abs = abs (integrand) mci%max_known = .true. end if end subroutine mci_midpoint_instance_record_integrand @ %def mci_midpoint_instance_record_integrand @ We store the safety factor, otherwise nothing to do here. <>= procedure :: init_simulation => mci_midpoint_instance_init_simulation procedure :: final_simulation => mci_midpoint_instance_final_simulation <>= subroutine mci_midpoint_instance_init_simulation (instance, safety_factor) class(mci_midpoint_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor if (present (safety_factor)) instance%safety_factor = safety_factor end subroutine mci_midpoint_instance_init_simulation subroutine mci_midpoint_instance_final_simulation (instance) class(mci_midpoint_instance_t), intent(inout) :: instance end subroutine mci_midpoint_instance_final_simulation @ %def mci_midpoint_instance_init_simulation @ %def mci_midpoint_instance_final_simulation @ Return excess weight for the current event. <>= procedure :: get_event_excess => mci_midpoint_instance_get_event_excess <>= function mci_midpoint_instance_get_event_excess (mci) result (excess) class(mci_midpoint_instance_t), intent(in) :: mci real(default) :: excess excess = mci%excess_weight end function mci_midpoint_instance_get_event_excess @ %def mci_midpoint_instance_get_event_excess @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_midpoint_ut.f90]]>>= <> module mci_midpoint_ut use unit_tests use mci_midpoint_uti <> <> contains <> end module mci_midpoint_ut @ %def mci_midpoint_ut @ <<[[mci_midpoint_uti.f90]]>>= <> module mci_midpoint_uti <> use io_units use rng_base use mci_base use mci_midpoint use rng_base_ut, only: rng_test_t <> <> <> contains <> end module mci_midpoint_uti @ %def mci_midpoint_ut @ API: driver for the unit tests below. <>= public :: mci_midpoint_test <>= subroutine mci_midpoint_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_midpoint_test @ %def mci_midpoint_test @ \subsubsection{Test sampler} A test sampler object should implement a function with known integral that we can use to check the integrator. This is the function $f(x) = 3 x^2$ with integral $\int_0^1 f(x)\,dx=1$ and maximum $f(1)=3$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). Mimicking the behavior of a process object, we store the argument and result inside the sampler, so we can [[fetch]] results. <>= type, extends (mci_sampler_t) :: test_sampler_1_t real(default), dimension(:), allocatable :: x real(default) :: val contains <> end type test_sampler_1_t @ %def test_sampler_1_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_1_write <>= subroutine test_sampler_1_write (object, unit, testflag) class(test_sampler_1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2" end subroutine test_sampler_1_write @ %def test_sampler_1_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_1_evaluate <>= subroutine test_sampler_1_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = 3 * x_in(1) ** 2 call sampler%fetch (val, x, f) end subroutine test_sampler_1_evaluate @ %def test_sampler_1_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_1_is_valid <>= function test_sampler_1_is_valid (sampler) result (valid) class(test_sampler_1_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_1_is_valid @ %def test_sampler_1_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_1_rebuild <>= subroutine test_sampler_1_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_rebuild @ %def test_sampler_1_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_1_fetch <>= subroutine test_sampler_1_fetch (sampler, val, x, f) class(test_sampler_1_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_fetch @ %def test_sampler_1_fetch @ This is the function $f(x) = 3 x^2 + 2 y$ with integral $\int_0^1 f(x,y)\,dx\,dy=2$ and maximum $f(1)=5$. <>= type, extends (mci_sampler_t) :: test_sampler_2_t real(default) :: val real(default), dimension(2) :: x contains <> end type test_sampler_2_t @ %def test_sampler_2_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_2_write <>= subroutine test_sampler_2_write (object, unit, testflag) class(test_sampler_2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2 + 2 y" end subroutine test_sampler_2_write @ %def test_sampler_2_write @ Evaluate: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_2_evaluate <>= subroutine test_sampler_2_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f sampler%x = x_in sampler%val = 3 * x_in(1) ** 2 + 2 * x_in(2) call sampler%fetch (val, x, f) end subroutine test_sampler_2_evaluate @ %def test_sampler_2_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_2_is_valid <>= function test_sampler_2_is_valid (sampler) result (valid) class(test_sampler_2_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_2_is_valid @ %def test_sampler_2_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_2_rebuild <>= subroutine test_sampler_2_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_2_rebuild @ %def test_sampler_2_rebuild <>= procedure :: fetch => test_sampler_2_fetch <>= subroutine test_sampler_2_fetch (sampler, val, x, f) class(test_sampler_2_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_2_fetch @ %def test_sampler_2_fetch @ This is the function $f(x) = (1 - 3 x^2)\,\theta(x-1/2)$ with integral $\int_0^1 f(x)\,dx=-3/8$, minimum $f(1)=-2$ and maximum $f(1/2)=1/4$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). <>= type, extends (mci_sampler_t) :: test_sampler_4_t real(default) :: val real(default), dimension(:), allocatable :: x contains <> end type test_sampler_4_t @ %def test_sampler_4_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_4_write <>= subroutine test_sampler_4_write (object, unit, testflag) class(test_sampler_4_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler: f(x) = 1 - 3 x^2" end subroutine test_sampler_4_write @ %def test_sampler_4_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_4_evaluate <>= subroutine test_sampler_4_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_4_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (x_in(1) >= .5_default) then sampler%val = 1 - 3 * x_in(1) ** 2 else sampler%val = 0 end if if (.not. allocated (sampler%x)) allocate (sampler%x (size (x_in))) sampler%x = x_in call sampler%fetch (val, x, f) end subroutine test_sampler_4_evaluate @ %def test_sampler_4_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_4_is_valid <>= function test_sampler_4_is_valid (sampler) result (valid) class(test_sampler_4_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_4_is_valid @ %def test_sampler_4_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_4_rebuild <>= subroutine test_sampler_4_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_4_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_4_rebuild @ %def test_sampler_4_rebuild <>= procedure :: fetch => test_sampler_4_fetch <>= subroutine test_sampler_4_fetch (sampler, val, x, f) class(test_sampler_4_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_4_fetch @ %def test_sampler_4_fetch @ \subsubsection{One-dimensional integration} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_midpoint_1, "mci_midpoint_1", & "one-dimensional integral", & u, results) <>= public :: mci_midpoint_1 <>= subroutine mci_midpoint_1 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_1" write (u, "(A)") "* Purpose: integrate function in one dimension" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.7" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.7_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.9" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.9_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_1" end subroutine mci_midpoint_1 @ %def mci_midpoint_1 @ \subsubsection{Two-dimensional integration} Construct an integrator and use it for a two-dimensional sampler. <>= call test (mci_midpoint_2, "mci_midpoint_2", & "two-dimensional integral", & u, results) <>= public :: mci_midpoint_2 <>= subroutine mci_midpoint_2 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_2" write (u, "(A)") "* Purpose: integrate function in two dimensions" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (2, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8, y = 0.2" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default, 0.2_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_2" end subroutine mci_midpoint_2 @ %def mci_midpoint_2 @ \subsubsection{Two-dimensional integration with flat dimension} Construct an integrator and use it for a two-dimensional sampler, where the function is constant in the second dimension. <>= call test (mci_midpoint_3, "mci_midpoint_3", & "two-dimensional integral with flat dimension", & u, results) <>= public :: mci_midpoint_3 <>= subroutine mci_midpoint_3 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_3" write (u, "(A)") "* Purpose: integrate function with one flat dimension" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) select type (mci) type is (mci_midpoint_t) call mci%set_dimensions (2, 1) call mci%declare_flat_dimensions ([2]) end select call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8, y = 0.2" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default, 0.2_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_3" end subroutine mci_midpoint_3 @ %def mci_midpoint_3 @ \subsubsection{Integrand with sign flip} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_midpoint_4, "mci_midpoint_4", & "integrand with sign flip", & u, results) <>= public :: mci_midpoint_4 <>= subroutine mci_midpoint_4 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_4" write (u, "(A)") "* Purpose: integrate function with sign flip & &in one dimension" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_4_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_4" end subroutine mci_midpoint_4 @ %def mci_midpoint_4 @ \subsubsection{Weighted events} Generate weighted events. Without rejection, we do not need to know maxima and minima, so we can start generating events immediately. We have two dimensions. <>= call test (mci_midpoint_5, "mci_midpoint_5", & "weighted events", & u, results) <>= public :: mci_midpoint_5 <>= subroutine mci_midpoint_5 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng class(mci_state_t), allocatable :: state write (u, "(A)") "* Test output: mci_midpoint_5" write (u, "(A)") "* Purpose: generate weighted events" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (2, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_2_t :: sampler) write (u, "(A)") "* Initialize random-number generator" write (u, "(A)") allocate (rng_test_t :: rng) call rng%init () call mci%import_rng (rng) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Store data" write (u, "(A)") allocate (state) call mci_instance%store (state) call mci_instance%final () deallocate (mci_instance) call state%write (u) write (u, "(A)") write (u, "(A)") "* Recall data and rebuild event" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci%rebuild_event (mci_instance, sampler, state) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () deallocate (mci_instance) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_5" end subroutine mci_midpoint_5 @ %def mci_midpoint_5 @ \subsubsection{Unweighted events} Generate unweighted events. The integrand has a sign flip in it. <>= call test (mci_midpoint_6, "mci_midpoint_6", & "unweighted events", & u, results) <>= public :: mci_midpoint_6 <>= subroutine mci_midpoint_6 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_midpoint_6" write (u, "(A)") "* Purpose: generate unweighted events" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_4_t :: sampler) write (u, "(A)") "* Initialize random-number generator" write (u, "(A)") allocate (rng_test_t :: rng) call rng%init () call mci%import_rng (rng) write (u, "(A)") "* Integrate (determine maximum of integrand" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci%generate_unweighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () deallocate (mci_instance) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_6" end subroutine mci_midpoint_6 @ %def mci_midpoint_6 @ \subsubsection{Excess weight} Generate unweighted events. With only 2 points for integration, the maximum of the integrand is too low, and we produce excess weight. <>= call test (mci_midpoint_7, "mci_midpoint_7", & "excess weight", & u, results) <>= public :: mci_midpoint_7 <>= subroutine mci_midpoint_7 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_midpoint_7" write (u, "(A)") "* Purpose: generate unweighted event & &with excess weight" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_4_t :: sampler) write (u, "(A)") "* Initialize random-number generator" write (u, "(A)") allocate (rng_test_t :: rng) call rng%init () call mci%import_rng (rng) write (u, "(A)") "* Integrate (determine maximum of integrand" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 2) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_unweighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Use getter methods" write (u, "(A)") write (u, "(1x,A,1x,ES19.12)") "weight =", mci_instance%get_event_weight () write (u, "(1x,A,1x,ES19.12)") "excess =", mci_instance%get_event_excess () write (u, "(A)") write (u, "(A)") "* Apply safety factor" write (u, "(A)") call mci_instance%init_simulation (safety_factor = 2.1_default) write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci%generate_unweighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Use getter methods" write (u, "(A)") write (u, "(1x,A,1x,ES19.12)") "weight =", mci_instance%get_event_weight () write (u, "(1x,A,1x,ES19.12)") "excess =", mci_instance%get_event_excess () write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () deallocate (mci_instance) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_7" end subroutine mci_midpoint_7 @ %def mci_midpoint_7 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{\vamp\ interface} The standard method for integration is \vamp: the multi-channel version of the VEGAS algorithm. Each parameterization (channel) of the hypercube is binned in each dimension. The binning is equally equidistant, but an iteration of the integration procedure, the binning is updated for each dimension, according to the variance distribution of the integrand, summed over all other dimension. In the next iteration, the binning approximates (hopefully) follows the integrand more closely, and the accuracy of the result is increased. Furthermore, the relative weight of the individual channels is also updated after an iteration. The bin distribution is denoted as the grid for a channel, which we can write to file and reuse later. In our implementation we specify the generic \vamp\ algorithm more tightly: the number of bins is equal for all dimensions, the initial weights are all equal. The user controls whether to update bins and/or weights after each iteration. The integration is organized in passes, each one consisting of several iterations with a common number of calls to the integrand. The first passes are intended as warmup, so the results are displayed but otherwise discarded. In the final pass, the integration estimates for the individual iterations are averaged for the final result. <<[[mci_vamp.f90]]>>= <> module mci_vamp <> <> use io_units use constants, only: zero use format_utils, only: pac_fmt use format_utils, only: write_separator use format_defs, only: FMT_12, FMT_14, FMT_17, FMT_19 use diagnostics use md5 use phs_base use rng_base use rng_tao use vamp !NODEP! use exceptions !NODEP! use mci_base <> <> <> <> contains <> end module mci_vamp @ %def mci_vamp @ \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 real(default) :: accuracy_goal = 0 real(default) :: error_goal = 0 real(default) :: rel_error_goal = 0 contains <> end type grid_parameters_t @ %def grid_parameters_t @ I/O: <>= procedure :: write => grid_parameters_write <>= subroutine grid_parameters_write (object, unit) class(grid_parameters_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A,I0)") "threshold_calls = ", & object%threshold_calls write (u, "(3x,A,I0)") "min_calls_per_channel = ", & object%min_calls_per_channel write (u, "(3x,A,I0)") "min_calls_per_bin = ", & object%min_calls_per_bin write (u, "(3x,A,I0)") "min_bins = ", & object%min_bins write (u, "(3x,A,I0)") "max_bins = ", & object%max_bins write (u, "(3x,A,L1)") "stratified = ", & object%stratified write (u, "(3x,A,L1)") "use_vamp_equivalences = ", & object%use_vamp_equivalences write (u, "(3x,A,F10.7)") "channel_weights_power = ", & object%channel_weights_power if (object%accuracy_goal > 0) then write (u, "(3x,A,F10.7)") "accuracy_goal = ", & object%accuracy_goal end if if (object%error_goal > 0) then write (u, "(3x,A,F10.7)") "error_goal = ", & object%error_goal end if if (object%rel_error_goal > 0) then write (u, "(3x,A,F10.7)") "rel_error_goal = ", & object%rel_error_goal end if end subroutine grid_parameters_write @ %def grid_parameters_write @ \subsection{History parameters} The history parameters are also stored in a transparent container. This is not a part of the grid definition, and should not be included in the MD5 sum. <>= public :: history_parameters_t <>= type :: history_parameters_t logical :: global = .true. logical :: global_verbose = .false. logical :: channel = .false. logical :: channel_verbose = .false. contains <> end type history_parameters_t @ %def history_parameters_t @ I/O: <>= procedure :: write => history_parameters_write <>= subroutine history_parameters_write (object, unit) class(history_parameters_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A,L1)") "history(global) = ", object%global write (u, "(3x,A,L1)") "history(global) verb. = ", object%global_verbose write (u, "(3x,A,L1)") "history(channels) = ", object%channel write (u, "(3x,A,L1)") "history(chann.) verb. = ", object%channel_verbose end subroutine history_parameters_write @ %def history_parameters_write @ \subsection{Integration pass} We store the parameters for each integration pass in a linked list. <>= type :: pass_t integer :: i_pass = 0 integer :: i_first_it = 0 integer :: n_it = 0 integer :: n_calls = 0 integer :: n_bins = 0 logical :: adapt_grids = .false. logical :: adapt_weights = .false. logical :: is_final_pass = .false. logical :: integral_defined = .false. integer, dimension(:), allocatable :: calls integer, dimension(:), allocatable :: calls_valid real(default), dimension(:), allocatable :: integral real(default), dimension(:), allocatable :: error real(default), dimension(:), allocatable :: efficiency type(vamp_history), dimension(:), allocatable :: v_history type(vamp_history), dimension(:,:), allocatable :: v_histories type(pass_t), pointer :: next => null () contains <> end type pass_t @ %def pass_t @ Finalizer. The VAMP histories contain a pointer array. <>= procedure :: final => pass_final <>= subroutine pass_final (object) class(pass_t), intent(inout) :: object if (allocated (object%v_history)) then call vamp_delete_history (object%v_history) end if if (allocated (object%v_histories)) then call vamp_delete_history (object%v_histories) end if end subroutine pass_final @ %def pass_final @ Output. Note that the precision of the numerical values should match the precision for comparing output from file with data. <>= procedure :: write => pass_write <>= subroutine pass_write (object, unit, pacify) class(pass_t), intent(in) :: object integer, intent(in) :: unit logical, intent(in), optional :: pacify integer :: u, i character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(3x,A,I0)") "n_it = ", object%n_it write (u, "(3x,A,I0)") "n_calls = ", object%n_calls write (u, "(3x,A,I0)") "n_bins = ", object%n_bins write (u, "(3x,A,L1)") "adapt grids = ", object%adapt_grids write (u, "(3x,A,L1)") "adapt weights = ", object%adapt_weights if (object%integral_defined) then write (u, "(3x,A)") "Results: [it, calls, valid, integral, error, efficiency]" do i = 1, object%n_it write (u, "(5x,I0,2(1x,I0),3(1x," // fmt // "))") & i, object%calls(i), object%calls_valid(i), object%integral(i), object%error(i), & object%efficiency(i) end do else write (u, "(3x,A)") "Results: [undefined]" end if end subroutine pass_write @ %def pass_write @ Read and reconstruct the pass. <>= procedure :: read => pass_read <>= subroutine pass_read (object, u, n_pass, n_it) class(pass_t), intent(out) :: object integer, intent(in) :: u, n_pass, n_it integer :: i, j character(80) :: buffer object%i_pass = n_pass + 1 object%i_first_it = n_it + 1 call read_ival (u, object%n_it) call read_ival (u, object%n_calls) call read_ival (u, object%n_bins) call read_lval (u, object%adapt_grids) call read_lval (u, object%adapt_weights) allocate (object%calls (object%n_it), source = 0) allocate (object%calls_valid (object%n_it), source = 0) allocate (object%integral (object%n_it), source = 0._default) allocate (object%error (object%n_it), source = 0._default) allocate (object%efficiency (object%n_it), source = 0._default) read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("Results: [it, calls, valid, integral, error, efficiency]") do i = 1, object%n_it read (u, *) & j, object%calls(i), object%calls_valid(i), object%integral(i), object%error(i), & object%efficiency(i) end do object%integral_defined = .true. case ("Results: [undefined]") object%integral_defined = .false. case default call msg_fatal ("Reading integration pass: corrupted file") end select end subroutine pass_read @ %def pass_read @ Write the VAMP history for this pass. (The subroutine writes the whole array at once.) <>= procedure :: write_history => pass_write_history <>= subroutine pass_write_history (pass, unit) class(pass_t), intent(in) :: pass integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (allocated (pass%v_history)) then call vamp_write_history (u, pass%v_history) else write (u, "(1x,A)") "Global history: [undefined]" end if if (allocated (pass%v_histories)) then write (u, "(1x,A)") "Channel histories:" call vamp_write_history (u, pass%v_histories) else write (u, "(1x,A)") "Channel histories: [undefined]" end if end subroutine pass_write_history @ %def pass_write_history @ Given a number of calls and iterations, compute remaining data. <>= procedure :: configure => pass_configure <>= subroutine pass_configure (pass, n_it, n_calls, min_calls, & min_bins, max_bins, min_channel_calls) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_it, n_calls, min_channel_calls integer, intent(in) :: min_calls, min_bins, max_bins pass%n_it = n_it if (min_calls /= 0) then pass%n_bins = max (min_bins, & min (n_calls / min_calls, max_bins)) else pass%n_bins = max_bins end if pass%n_calls = max (n_calls, max (min_calls, min_channel_calls)) if (pass%n_calls /= n_calls) then write (msg_buffer, "(A,I0)") "VAMP: too few calls, resetting " & // "n_calls to ", pass%n_calls call msg_warning () end if allocate (pass%calls (n_it), source = 0) allocate (pass%calls_valid (n_it), source = 0) allocate (pass%integral (n_it), source = 0._default) allocate (pass%error (n_it), source = 0._default) allocate (pass%efficiency (n_it), source = 0._default) end subroutine pass_configure @ %def pass_configure @ Allocate the VAMP history and give options. We assume that the [[configure]] routine above has been executed, so the number of iterations is known. <>= procedure :: configure_history => pass_configure_history <>= subroutine pass_configure_history (pass, n_channels, par) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_channels type(history_parameters_t), intent(in) :: par if (par%global) then allocate (pass%v_history (pass%n_it)) call vamp_create_history (pass%v_history, & verbose = par%global_verbose) end if if (par%channel) then allocate (pass%v_histories (pass%n_it, n_channels)) call vamp_create_history (pass%v_histories, & verbose = par%channel_verbose) end if end subroutine pass_configure_history @ %def pass_configure_history @ Given two pass objects, compare them. All parameters must match. Where integrations are done in both (number of calls nonzero), the results must be equal (up to numerical noise). The allocated array sizes might be different, but should match up to the common [[n_it]] value. <>= interface operator (.matches.) module procedure pass_matches end interface operator (.matches.) <>= function pass_matches (pass, ref) result (ok) type(pass_t), intent(in) :: pass, ref integer :: n logical :: ok ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_it == ref%n_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%n_bins == ref%n_bins if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) ok = pass%integral_defined .eqv. ref%integral_defined if (pass%integral_defined) then n = pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid (:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) end if end function pass_matches @ %def pass_matches @ Update a pass object, given a reference. The parameters must match, except for the [[n_it]] entry. The number of complete iterations must be less or equal to the reference, and the number of complete iterations in the reference must be no larger than [[n_it]]. Where results are present in both passes, they must match. Where results are present in the reference only, the pass is updated accordingly. <>= procedure :: update => pass_update <>= subroutine pass_update (pass, ref, ok) class(pass_t), intent(inout) :: pass type(pass_t), intent(in) :: ref logical, intent(out) :: ok integer :: n, n_ref ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%n_bins == ref%n_bins if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) then if (ref%integral_defined) then if (.not. allocated (pass%calls)) then allocate (pass%calls (pass%n_it), source = 0) allocate (pass%calls_valid (pass%n_it), source = 0) allocate (pass%integral (pass%n_it), source = 0._default) allocate (pass%error (pass%n_it), source = 0._default) allocate (pass%efficiency (pass%n_it), source = 0._default) end if n = count (pass%calls /= 0) n_ref = count (ref%calls /= 0) ok = n <= n_ref .and. n_ref <= pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid(:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) if (ok) then pass%calls(n+1:n_ref) = ref%calls(n+1:n_ref) pass%calls_valid(n+1:n_ref) = ref%calls_valid(n+1:n_ref) pass%integral(n+1:n_ref) = ref%integral(n+1:n_ref) pass%error(n+1:n_ref) = ref%error(n+1:n_ref) pass%efficiency(n+1:n_ref) = ref%efficiency(n+1:n_ref) pass%integral_defined = any (pass%calls /= 0) end if end if end if end subroutine pass_update @ %def pass_update @ Match two real numbers: they are equal up to a tolerance, which is $10^{-8}$, matching the number of digits that are output by [[pass_write]]. In particular, if one number is exactly zero, the other one must also be zero. <>= interface operator (.matches.) module procedure real_matches end interface operator (.matches.) <>= elemental function real_matches (x, y) result (ok) real(default), intent(in) :: x, y logical :: ok real(default), parameter :: tolerance = 1.e-8_default ok = abs (x - y) <= tolerance * max (abs (x), abs (y)) end function real_matches @ %def real_matches @ Return the index of the most recent complete integration. If there is none, return zero. <>= procedure :: get_integration_index => pass_get_integration_index <>= function pass_get_integration_index (pass) result (n) class (pass_t), intent(in) :: pass integer :: n integer :: i n = 0 if (allocated (pass%calls)) then do i = 1, pass%n_it if (pass%calls(i) == 0) exit n = i end do end if end function pass_get_integration_index @ %def pass_get_integration_index @ Return the most recent integral and error, if available. <>= procedure :: get_calls => pass_get_calls procedure :: get_calls_valid => pass_get_calls_valid procedure :: get_integral => pass_get_integral procedure :: get_error => pass_get_error procedure :: get_efficiency => pass_get_efficiency <>= function pass_get_calls (pass) result (calls) class(pass_t), intent(in) :: pass integer :: calls integer :: n n = pass%get_integration_index () if (n /= 0) then calls = pass%calls(n) else calls = 0 end if end function pass_get_calls function pass_get_calls_valid (pass) result (calls_valid) class(pass_t), intent(in) :: pass integer :: calls_valid integer :: n n = pass%get_integration_index () if (n /= 0) then calls_valid = pass%calls_valid(n) else calls_valid = 0 end if end function pass_get_calls_valid function pass_get_integral (pass) result (integral) class(pass_t), intent(in) :: pass real(default) :: integral integer :: n n = pass%get_integration_index () if (n /= 0) then integral = pass%integral(n) else integral = 0 end if end function pass_get_integral function pass_get_error (pass) result (error) class(pass_t), intent(in) :: pass real(default) :: error integer :: n n = pass%get_integration_index () if (n /= 0) then error = pass%error(n) else error = 0 end if end function pass_get_error function pass_get_efficiency (pass) result (efficiency) class(pass_t), intent(in) :: pass real(default) :: efficiency integer :: n n = pass%get_integration_index () if (n /= 0) then efficiency = pass%efficiency(n) else efficiency = 0 end if end function pass_get_efficiency @ %def pass_get_calls @ %def pass_get_calls_valid @ %def pass_get_integral @ %def pass_get_error @ %def pass_get_efficiency @ \subsection{Integrator} <>= public :: mci_vamp_t <>= type, extends (mci_t) :: mci_vamp_t logical, dimension(:), allocatable :: dim_is_flat type(grid_parameters_t) :: grid_par type(history_parameters_t) :: history_par integer :: min_calls = 0 type(pass_t), pointer :: first_pass => null () type(pass_t), pointer :: current_pass => null () type(vamp_equivalences_t) :: equivalences logical :: rebuild = .true. logical :: check_grid_file = .true. logical :: grid_filename_set = .false. logical :: negative_weights = .false. logical :: verbose = .false. type(string_t) :: grid_filename character(32) :: md5sum_adapted = "" contains <> end type mci_vamp_t @ %def mci_vamp_t @ Reset: delete integration-pass entries. <>= procedure :: reset => mci_vamp_reset <>= subroutine mci_vamp_reset (object) class(mci_vamp_t), intent(inout) :: object type(pass_t), pointer :: current_pass do while (associated (object%first_pass)) current_pass => object%first_pass object%first_pass => current_pass%next call current_pass%final () deallocate (current_pass) end do object%current_pass => null () end subroutine mci_vamp_reset @ %def mci_vamp_reset @ Finalizer: reset and finalize the equivalences list. <>= procedure :: final => mci_vamp_final <>= subroutine mci_vamp_final (object) class(mci_vamp_t), intent(inout) :: object call object%reset () call vamp_equivalences_final (object%equivalences) call object%base_final () end subroutine mci_vamp_final @ %def mci_vamp_final @ Output. Do not output the grids themselves, this may result in tons of data. <>= procedure :: write => mci_vamp_write <>= subroutine mci_vamp_write (object, unit, pacify, md5sum_version) class(mci_vamp_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version type(pass_t), pointer :: current_pass integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "VAMP integrator:" call object%base_write (u, pacify, md5sum_version) if (allocated (object%dim_is_flat)) then write (u, "(3x,A,999(1x,I0))") "Flat dimensions =", & pack ([(i, i = 1, object%n_dim)], object%dim_is_flat) end if write (u, "(1x,A)") "Grid parameters:" call object%grid_par%write (u) write (u, "(3x,A,I0)") "min_calls = ", object%min_calls write (u, "(3x,A,L1)") "negative weights = ", & object%negative_weights write (u, "(3x,A,L1)") "verbose = ", & object%verbose if (object%grid_par%use_vamp_equivalences) then call vamp_equivalences_write (object%equivalences, u) end if current_pass => object%first_pass do while (associated (current_pass)) write (u, "(1x,A,I0,A)") "Integration pass:" call current_pass%write (u, pacify) current_pass => current_pass%next end do if (object%md5sum_adapted /= "") then write (u, "(1x,A,A,A)") "MD5 sum (including results) = '", & object%md5sum_adapted, "'" end if end subroutine mci_vamp_write @ %def mci_vamp_write @ Write the history parameters. <>= procedure :: write_history_parameters => mci_vamp_write_history_parameters <>= subroutine mci_vamp_write_history_parameters (mci, unit) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "VAMP history parameters:" call mci%history_par%write (unit) end subroutine mci_vamp_write_history_parameters @ %def mci_vamp_write_history_parameters @ Write the history, iterating over passes. We keep this separate from the generic [[write]] routine. <>= procedure :: write_history => mci_vamp_write_history <>= subroutine mci_vamp_write_history (mci, unit) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit type(pass_t), pointer :: current_pass integer :: i_pass integer :: u u = given_output_unit (unit) if (associated (mci%first_pass)) then write (u, "(1x,A)") "VAMP history (global):" i_pass = 0 current_pass => mci%first_pass do while (associated (current_pass)) i_pass = i_pass + 1 write (u, "(1x,A,I0,':')") "Pass #", i_pass call current_pass%write_history (u) current_pass => current_pass%next end do end if end subroutine mci_vamp_write_history @ %def mci_vamp_write_history @ Compute the MD5 sum, including the configuration MD5 sum and the printout, which incorporates the current results. <>= procedure :: compute_md5sum => mci_vamp_compute_md5sum <>= subroutine mci_vamp_compute_md5sum (mci, pacify) class(mci_vamp_t), intent(inout) :: mci logical, intent(in), optional :: pacify integer :: u mci%md5sum_adapted = "" u = free_unit () open (u, status = "scratch", action = "readwrite") write (u, "(A)") mci%md5sum call mci%write (u, pacify, md5sum_version = .true.) rewind (u) mci%md5sum_adapted = md5sum (u) close (u) end subroutine mci_vamp_compute_md5sum @ %def mci_vamp_compute_md5sum @ Return the MD5 sum: If available, return the adapted one. <>= procedure :: get_md5sum => mci_vamp_get_md5sum <>= pure function mci_vamp_get_md5sum (mci) result (md5sum) class(mci_vamp_t), intent(in) :: mci character(32) :: md5sum if (mci%md5sum_adapted /= "") then md5sum = mci%md5sum_adapted else md5sum = mci%md5sum end if end function mci_vamp_get_md5sum @ %def mci_vamp_get_md5sum @ Startup message: short version. <>= procedure :: startup_message => mci_vamp_startup_message <>= subroutine mci_vamp_startup_message (mci, unit, n_calls) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls integer :: num_calls, n_bins if (present (n_calls)) then num_calls = n_calls else num_calls = 0 end if if (mci%min_calls /= 0) then n_bins = max (mci%grid_par%min_bins, & min (num_calls / mci%min_calls, & mci%grid_par%max_bins)) else n_bins = mci%grid_par%max_bins end if call mci%base_startup_message (unit = unit, n_calls = n_calls) if (mci%grid_par%use_vamp_equivalences) then write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: Using VAMP channel equivalences" call msg_message (unit = unit) end if write (msg_buffer, "(A,2(1x,I0,1x,A),L1)") & "Integrator:", num_calls, & "initial calls,", n_bins, & "bins, stratified = ", & mci%grid_par%stratified call msg_message (unit = unit) write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: VAMP" call msg_message (unit = unit) end subroutine mci_vamp_startup_message @ %def mci_vamp_startup_message @ Log entry: just headline. <>= procedure :: write_log_entry => mci_vamp_write_log_entry <>= subroutine mci_vamp_write_log_entry (mci, u) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is VAMP" call write_separator (u) call mci%write_history (u) call write_separator (u) if (mci%grid_par%use_vamp_equivalences) then call vamp_equivalences_write (mci%equivalences, u) else write (u, "(3x,A)") "No VAMP equivalences have been used" end if call write_separator (u) call mci%write_chain_weights (u) end subroutine mci_vamp_write_log_entry @ %def mci_vamp_write_log_entry @ Set the MCI index (necessary for processes with multiple components). We append the index to the grid filename, just before the final dotted suffix. <>= procedure :: record_index => mci_vamp_record_index <>= subroutine mci_vamp_record_index (mci, i_mci) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: i_mci type(string_t) :: basename, suffix character(32) :: buffer if (mci%grid_filename_set) then basename = mci%grid_filename call split (basename, suffix, ".", back=.true.) write (buffer, "(I0)") i_mci if (basename /= "") then mci%grid_filename = basename // ".m" // trim (buffer) // "." // suffix else mci%grid_filename = suffix // ".m" // trim (buffer) // ".vg" end if end if end subroutine mci_vamp_record_index @ %def mci_vamp_record_index @ Set the grid parameters. <>= procedure :: set_grid_parameters => mci_vamp_set_grid_parameters <>= subroutine mci_vamp_set_grid_parameters (mci, grid_par) class(mci_vamp_t), intent(inout) :: mci type(grid_parameters_t), intent(in) :: grid_par mci%grid_par = grid_par mci%min_calls = grid_par%min_calls_per_bin * mci%n_channel end subroutine mci_vamp_set_grid_parameters @ %def mci_vamp_set_grid_parameters @ Set the history parameters. <>= procedure :: set_history_parameters => mci_vamp_set_history_parameters <>= subroutine mci_vamp_set_history_parameters (mci, history_par) class(mci_vamp_t), intent(inout) :: mci type(history_parameters_t), intent(in) :: history_par mci%history_par = history_par end subroutine mci_vamp_set_history_parameters @ %def mci_vamp_set_history_parameters @ Set the rebuild flag, also the flag for checking the grid file. <>= procedure :: set_rebuild_flag => mci_vamp_set_rebuild_flag <>= subroutine mci_vamp_set_rebuild_flag (mci, rebuild, check_grid_file) class(mci_vamp_t), intent(inout) :: mci logical, intent(in) :: rebuild logical, intent(in) :: check_grid_file mci%rebuild = rebuild mci%check_grid_file = check_grid_file end subroutine mci_vamp_set_rebuild_flag @ %def mci_vamp_set_rebuild_flag @ Set the filename. <>= procedure :: set_grid_filename => mci_vamp_set_grid_filename <>= subroutine mci_vamp_set_grid_filename (mci, name, run_id) class(mci_vamp_t), intent(inout) :: mci type(string_t), intent(in) :: name type(string_t), intent(in), optional :: run_id if (present (run_id)) then mci%grid_filename = name // "." // run_id // ".vg" else mci%grid_filename = name // ".vg" end if mci%grid_filename_set = .true. end subroutine mci_vamp_set_grid_filename @ %def mci_vamp_set_grid_filename @ To simplify the interface, we prepend a grid path in a separate subroutine. <>= procedure :: prepend_grid_path => mci_vamp_prepend_grid_path <>= subroutine mci_vamp_prepend_grid_path (mci, prefix) class(mci_vamp_t), intent(inout) :: mci type(string_t), intent(in) :: prefix if (mci%grid_filename_set) then mci%grid_filename = prefix // "/" // mci%grid_filename else call msg_warning ("Cannot add prefix to invalid grid filename!") end if end subroutine mci_vamp_prepend_grid_path @ %def mci_vamp_prepend_grid_path @ Declare particular dimensions as flat. <>= procedure :: declare_flat_dimensions => mci_vamp_declare_flat_dimensions <>= subroutine mci_vamp_declare_flat_dimensions (mci, dim_flat) class(mci_vamp_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat integer :: d allocate (mci%dim_is_flat (mci%n_dim), source = .false.) do d = 1, size (dim_flat) mci%dim_is_flat(dim_flat(d)) = .true. end do end subroutine mci_vamp_declare_flat_dimensions @ %def mci_vamp_declare_flat_dimensions @ Declare equivalences. We have an array of channel equivalences, provided by the phase-space module. Here, we translate this into the [[vamp_equivalences]] array. <>= procedure :: declare_equivalences => mci_vamp_declare_equivalences <>= subroutine mci_vamp_declare_equivalences (mci, channel, dim_offset) class(mci_vamp_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset integer, dimension(:), allocatable :: perm, mode integer :: n_channels, n_dim, n_equivalences integer :: c, i, j, left, right integer :: n_dim_perm n_channels = mci%n_channel n_dim = mci%n_dim n_equivalences = 0 do c = 1, n_channels n_equivalences = n_equivalences + size (channel(c)%eq) end do call vamp_equivalences_init (mci%equivalences, & n_equivalences, n_channels, n_dim) allocate (perm (n_dim)) allocate (mode (n_dim)) perm = [(i, i = 1, n_dim)] mode = VEQ_IDENTITY c = 1 j = 0 do i = 1, n_equivalences if (j < size (channel(c)%eq)) then j = j + 1 else c = c + 1 j = 1 end if associate (eq => channel(c)%eq(j)) left = c right = eq%c n_dim_perm = size (eq%perm) perm(dim_offset + 1:dim_offset + n_dim_perm) = eq%perm + dim_offset mode(dim_offset + 1:dim_offset + n_dim_perm) = eq%mode call vamp_equivalence_set (mci%equivalences, & i, left, right, perm, mode) end associate end do call vamp_equivalences_complete (mci%equivalences) end subroutine mci_vamp_declare_equivalences @ %def mci_vamp_declare_equivalences @ Allocate instance with matching type. <>= procedure :: allocate_instance => mci_vamp_allocate_instance <>= subroutine mci_vamp_allocate_instance (mci, mci_instance) class(mci_vamp_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_vamp_instance_t :: mci_instance) end subroutine mci_vamp_allocate_instance @ %def mci_vamp_allocate_instance @ Allocate a new integration pass. We can preset everything that does not depend on the number of iterations and calls. This is postponed to the [[integrate]] method. In the final pass, we do not check accuracy goal etc., since we can assume that the user wants to perform and average all iterations in this pass. <>= procedure :: add_pass => mci_vamp_add_pass <>= subroutine mci_vamp_add_pass (mci, adapt_grids, adapt_weights, final_pass) class(mci_vamp_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass integer :: i_pass, i_it type(pass_t), pointer :: new allocate (new) if (associated (mci%current_pass)) then i_pass = mci%current_pass%i_pass + 1 i_it = mci%current_pass%i_first_it + mci%current_pass%n_it mci%current_pass%next => new else i_pass = 1 i_it = 1 mci%first_pass => new end if mci%current_pass => new new%i_pass = i_pass new%i_first_it = i_it if (present (adapt_grids)) then new%adapt_grids = adapt_grids else new%adapt_grids = .false. end if if (present (adapt_weights)) then new%adapt_weights = adapt_weights else new%adapt_weights = .false. end if if (present (final_pass)) then new%is_final_pass = final_pass else new%is_final_pass = .false. end if end subroutine mci_vamp_add_pass @ %def mci_vamp_add_pass @ Update the list of integration passes. All passes except for the last one must match exactly. For the last one, integration results are updated. The reference output may contain extra passes, these are ignored. <>= procedure :: update_from_ref => mci_vamp_update_from_ref <>= subroutine mci_vamp_update_from_ref (mci, mci_ref, success) class(mci_vamp_t), intent(inout) :: mci class(mci_t), intent(in) :: mci_ref logical, intent(out) :: success type(pass_t), pointer :: current_pass, ref_pass select type (mci_ref) type is (mci_vamp_t) current_pass => mci%first_pass ref_pass => mci_ref%first_pass success = .true. do while (success .and. associated (current_pass)) if (associated (ref_pass)) then if (associated (current_pass%next)) then success = current_pass .matches. ref_pass else call current_pass%update (ref_pass, success) if (current_pass%integral_defined) then mci%integral = current_pass%get_integral () mci%error = current_pass%get_error () mci%efficiency = current_pass%get_efficiency () mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. end if end if current_pass => current_pass%next ref_pass => ref_pass%next else success = .false. end if end do end select end subroutine mci_vamp_update_from_ref @ %def mci_vamp_update @ Update the MCI record (i.e., the integration passes) by reading from input stream. The stream should contain a [[write]] output from a previous run. We first check the MD5 sum of the configuration parameters. If that matches, we proceed directly to the stored integration passes. If successful, we may continue to read the file; the position will be after a blank line that must follow the MCI record. <>= procedure :: update => mci_vamp_update <>= subroutine mci_vamp_update (mci, u, success) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: u logical, intent(out) :: success character(80) :: buffer character(32) :: md5sum_file type(mci_vamp_t) :: mci_file integer :: n_pass, n_it call read_sval (u, md5sum_file) if (mci%check_grid_file) then success = md5sum_file == mci%md5sum else success = .true. end if if (success) then read (u, *) read (u, "(A)") buffer if (trim (adjustl (buffer)) == "VAMP integrator:") then n_pass = 0 n_it = 0 do read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("") exit case ("Integration pass:") call mci_file%add_pass () call mci_file%current_pass%read (u, n_pass, n_it) n_pass = n_pass + 1 n_it = n_it + mci_file%current_pass%n_it end select end do call mci%update_from_ref (mci_file, success) call mci_file%final () else call msg_fatal ("VAMP: reading grid file: corrupted data") end if end if end subroutine mci_vamp_update @ %def mci_vamp_update @ Read / write grids from / to file. Bug fix for 2.2.5: after reading grids from file, channel weights must be copied back to the [[mci_instance]] record. <>= procedure :: write_grids => mci_vamp_write_grids procedure :: read_grids_header => mci_vamp_read_grids_header procedure :: read_grids_data => mci_vamp_read_grids_data procedure :: read_grids => mci_vamp_read_grids <>= subroutine mci_vamp_write_grids (mci, instance) class(mci_vamp_t), intent(in) :: mci class(mci_instance_t), intent(inout) :: instance integer :: u select type (instance) type is (mci_vamp_instance_t) if (mci%grid_filename_set) then if (instance%grids_defined) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "write", status = "replace") write (u, "(1x,A,A,A)") "MD5sum = '", mci%md5sum, "'" write (u, *) call mci%write (u) write (u, *) write (u, "(1x,A)") "VAMP grids:" call vamp_write_grids (instance%grids, u, & write_integrals = .true.) close (u) else call msg_bug ("VAMP: write grids: grids undefined") end if else call msg_bug ("VAMP: write grids: filename undefined") end if end select end subroutine mci_vamp_write_grids subroutine mci_vamp_read_grids_header (mci, success) class(mci_vamp_t), intent(inout) :: mci logical, intent(out) :: success logical :: exist integer :: u success = .false. if (mci%grid_filename_set) then inquire (file = char (mci%grid_filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "read", status = "old") call mci%update (u, success) close (u) if (.not. success) then write (msg_buffer, "(A,A,A)") & "VAMP: parameter mismatch, discarding grid file '", & char (mci%grid_filename), "'" call msg_message () end if end if else call msg_bug ("VAMP: read grids: filename undefined") end if end subroutine mci_vamp_read_grids_header subroutine mci_vamp_read_grids_data (mci, instance, read_integrals) class(mci_vamp_t), intent(in) :: mci class(mci_instance_t), intent(inout) :: instance logical, intent(in), optional :: read_integrals integer :: u character(80) :: buffer select type (instance) type is (mci_vamp_instance_t) if (.not. instance%grids_defined) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "read", status = "old") do read (u, "(A)") buffer if (trim (adjustl (buffer)) == "VAMP grids:") exit end do call vamp_read_grids (instance%grids, u, read_integrals) close (u) call instance%set_channel_weights (instance%grids%weights) instance%grids_defined = .true. else call msg_bug ("VAMP: read grids: grids already defined") end if end select end subroutine mci_vamp_read_grids_data subroutine mci_vamp_read_grids (mci, instance, success) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance logical, intent(out) :: success logical :: exist integer :: u character(80) :: buffer select type (instance) type is (mci_vamp_instance_t) success = .false. if (mci%grid_filename_set) then if (.not. instance%grids_defined) then inquire (file = char (mci%grid_filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "read", status = "old") call mci%update (u, success) if (success) then read (u, "(A)") buffer if (trim (adjustl (buffer)) == "VAMP grids:") then call vamp_read_grids (instance%grids, u) else call msg_fatal ("VAMP: reading grid file: & &corrupted grid data") end if else write (msg_buffer, "(A,A,A)") & "VAMP: parameter mismatch, discarding grid file '", & char (mci%grid_filename), "'" call msg_message () end if close (u) instance%grids_defined = success end if else call msg_bug ("VAMP: read grids: grids already defined") end if else call msg_bug ("VAMP: read grids: filename undefined") end if end select end subroutine mci_vamp_read_grids @ %def mci_vamp_write_grids @ %def mci_vamp_read_grids_header @ %def mci_vamp_read_grids_data @ %def mci_vamp_read_grids @ Auxiliary: Read real, integer, string value. We search for an equals sign, the value must follow. <>= subroutine read_rval (u, rval) integer, intent(in) :: u real(default), intent(out) :: rval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) rval end subroutine read_rval subroutine read_ival (u, ival) integer, intent(in) :: u integer, intent(out) :: ival character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) ival end subroutine read_ival subroutine read_sval (u, sval) integer, intent(in) :: u character(*), intent(out) :: sval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) sval end subroutine read_sval subroutine read_lval (u, lval) integer, intent(in) :: u logical, intent(out) :: lval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) lval end subroutine read_lval @ %def read_rval read_ival read_sval read_lval @ Integrate. Perform a new integration pass (possibly reusing previous results), which may consist of several iterations. Note: we record the integral once per iteration. The integral stored in the [[mci]] record itself is the last integral of the current iteration, no averaging done. The [[results]] record may average results. In case we read the integration from file and we added new iterations to the pass preserving number of calls, we need to reshape the grids in order to incorporate the correct number of calls. Else the grids would be sampled with the number of calls from the grids file, which does not need to coincide with the number of calls from the pass. Note: recording the efficiency is not supported yet. <>= procedure :: integrate => mci_vamp_integrate <>= subroutine mci_vamp_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_results_t), intent(inout), optional :: results logical, intent(in), optional :: pacify integer :: it logical :: reshape, from_file, success select type (instance) type is (mci_vamp_instance_t) if (associated (mci%current_pass)) then mci%current_pass%integral_defined = .false. call mci%current_pass%configure (n_it, n_calls, & mci%min_calls, mci%grid_par%min_bins, & mci%grid_par%max_bins, & mci%grid_par%min_calls_per_channel * mci%n_channel) call mci%current_pass%configure_history & (mci%n_channel, mci%history_par) instance%pass_complete = .false. instance%it_complete = .false. call instance%new_pass (reshape) if (.not. instance%grids_defined .or. instance%grids_from_file) then if (mci%grid_filename_set .and. .not. mci%rebuild) then call mci%read_grids_header (success) from_file = success if (.not. instance%grids_defined .and. success) then call mci%read_grids_data (instance) end if else from_file = .false. end if else from_file = .false. end if if (from_file) then if (.not. mci%check_grid_file) & call msg_warning ("Reading grid file: MD5 sum check disabled") call msg_message ("VAMP: " & // "using grids and results from file '" & // char (mci%grid_filename) // "'") else if (.not. instance%grids_defined) then call instance%create_grids () end if do it = 1, instance%n_it if (signal_is_pending ()) return reshape = reshape .or. & (instance%grids_from_file .and. n_it > mci%current_pass%get_integration_index ()) instance%grids_from_file = from_file .and. & it <= mci%current_pass%get_integration_index () if (.not. instance%grids_from_file) then instance%it_complete = .false. call instance%adapt_grids () if (signal_is_pending ()) return call instance%adapt_weights () if (signal_is_pending ()) return call instance%discard_integrals (reshape) if (mci%grid_par%use_vamp_equivalences) then call instance%sample_grids (mci%rng, sampler, & mci%equivalences) else call instance%sample_grids (mci%rng, sampler) end if if (signal_is_pending ()) return instance%it_complete = .true. if (instance%integral /= 0) then mci%current_pass%calls(it) = instance%calls mci%current_pass%calls_valid(it) = instance%calls_valid mci%current_pass%integral(it) = instance%integral if (abs (instance%error / instance%integral) & > epsilon (1._default)) then mci%current_pass%error(it) = instance%error end if mci%current_pass%efficiency(it) = instance%efficiency end if mci%current_pass%integral_defined = .true. end if if (present (results)) then if (mci%has_chains ()) then call mci%collect_chain_weights (instance%w) call results%record (1, & n_calls = mci%current_pass%calls(it), & n_calls_valid = mci%current_pass%calls_valid(it), & integral = mci%current_pass%integral(it), & error = mci%current_pass%error(it), & efficiency = mci%current_pass%efficiency(it), & ! TODO Insert pos. and neg. Efficiency from VAMP. efficiency_pos = 0._default, & efficiency_neg = 0._default, & chain_weights = mci%chain_weights, & suppress = pacify) else call results%record (1, & n_calls = mci%current_pass%calls(it), & n_calls_valid = mci%current_pass%calls_valid(it), & integral = mci%current_pass%integral(it), & error = mci%current_pass%error(it), & efficiency = mci%current_pass%efficiency(it), & ! TODO Insert pos. and neg. Efficiency from VAMP. efficiency_pos = 0._default, & efficiency_neg = 0._default, & suppress = pacify) end if end if if (.not. instance%grids_from_file & .and. mci%grid_filename_set) then call mci%write_grids (instance) end if call instance%allow_adaptation () reshape = .false. if (.not. mci%current_pass%is_final_pass) then call mci%check_goals (it, success) if (success) exit end if end do if (signal_is_pending ()) return instance%pass_complete = .true. mci%integral = mci%current_pass%get_integral() mci%error = mci%current_pass%get_error() mci%efficiency = mci%current_pass%get_efficiency() mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. call mci%compute_md5sum (pacify) else call msg_bug ("MCI integrate: current_pass object not allocated") end if end select end subroutine mci_vamp_integrate @ %def mci_vamp_integrate @ Check whether we are already finished with this pass. <>= procedure :: check_goals => mci_vamp_check_goals <>= subroutine mci_vamp_check_goals (mci, it, success) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: it logical, intent(out) :: success success = .false. if (mci%error_reached (it)) then mci%current_pass%n_it = it call msg_message ("VAMP: error goal reached; & &skipping iterations") success = .true. return end if if (mci%rel_error_reached (it)) then mci%current_pass%n_it = it call msg_message ("VAMP: relative error goal reached; & &skipping iterations") success = .true. return end if if (mci%accuracy_reached (it)) then mci%current_pass%n_it = it call msg_message ("VAMP: accuracy goal reached; & &skipping iterations") success = .true. return end if end subroutine mci_vamp_check_goals @ %def mci_vamp_check_goals @ Return true if the error, relative error, or accuracy goal has been reached, if any. <>= procedure :: error_reached => mci_vamp_error_reached procedure :: rel_error_reached => mci_vamp_rel_error_reached procedure :: accuracy_reached => mci_vamp_accuracy_reached <>= function mci_vamp_error_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag real(default) :: error_goal, error error_goal = mci%grid_par%error_goal if (error_goal > 0) then associate (pass => mci%current_pass) if (pass%integral_defined) then error = abs (pass%error(it)) flag = error < error_goal else flag = .false. end if end associate else flag = .false. end if end function mci_vamp_error_reached function mci_vamp_rel_error_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag real(default) :: rel_error_goal, rel_error rel_error_goal = mci%grid_par%rel_error_goal if (rel_error_goal > 0) then associate (pass => mci%current_pass) if (pass%integral_defined) then if (pass%integral(it) /= 0) then rel_error = abs (pass%error(it) / pass%integral(it)) flag = rel_error < rel_error_goal else flag = .true. end if else flag = .false. end if end associate else flag = .false. end if end function mci_vamp_rel_error_reached function mci_vamp_accuracy_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag real(default) :: accuracy_goal, accuracy accuracy_goal = mci%grid_par%accuracy_goal if (accuracy_goal > 0) then associate (pass => mci%current_pass) if (pass%integral_defined) then if (pass%integral(it) /= 0) then accuracy = abs (pass%error(it) / pass%integral(it)) & * sqrt (real (pass%calls(it), default)) flag = accuracy < accuracy_goal else flag = .true. end if else flag = .false. end if end associate else flag = .false. end if end function mci_vamp_accuracy_reached @ %def mci_vamp_error_reached @ %def mci_vamp_rel_error_reached @ %def mci_vamp_accuracy_reached @ Prepare an event generation pass. Should be called before a sequence of events is generated, then we should call the corresponding finalizer. The pass-specific data of the previous integration pass are retained, but we reset the number of iterations and calls to zero. The latter now counts the number of events (calls to the sampling function, actually). <>= procedure :: prepare_simulation => mci_vamp_prepare_simulation <>= subroutine mci_vamp_prepare_simulation (mci) class(mci_vamp_t), intent(inout) :: mci logical :: success if (mci%grid_filename_set) then call mci%read_grids_header (success) call mci%compute_md5sum () if (.not. success) then call msg_fatal ("Simulate: " & // "reading integration grids from file '" & // char (mci%grid_filename) // "' failed") end if else call msg_bug ("VAMP: simulation: no grids, no grid filename") end if end subroutine mci_vamp_prepare_simulation @ %def mci_vamp_prepare_simulation @ Generate weighted event. Note that the event weight ([[vamp_weight]]) is not just the MCI weight. [[vamp_next_event]] selects a channel based on the channel weights multiplied by the (previously recorded) maximum integrand value of the channel. The MCI weight is renormalized accordingly, to cancel this effect on the result. <>= procedure :: generate_weighted_event => mci_vamp_generate_weighted_event <>= subroutine mci_vamp_generate_weighted_event (mci, instance, sampler) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler class(vamp_data_t), allocatable :: data type(exception) :: vamp_exception select type (instance) type is (mci_vamp_instance_t) instance%vamp_weight_set = .false. allocate (mci_workspace_t :: data) select type (data) type is (mci_workspace_t) data%sampler => sampler data%instance => instance end select select type (rng => mci%rng) type is (rng_tao_t) if (instance%grids_defined) then call vamp_next_event ( & instance%vamp_x, & rng%state, & instance%grids, & vamp_sampling_function, & data, & phi = phi_trivial, & weight = instance%vamp_weight, & exc = vamp_exception) call handle_vamp_exception (vamp_exception, mci%verbose) instance%vamp_excess = 0 instance%vamp_weight_set = .true. else call msg_bug ("VAMP: generate event: grids undefined") end if class default call msg_fatal ("VAMP event generation: & &random-number generator must be TAO") end select end select end subroutine mci_vamp_generate_weighted_event @ %def mci_vamp_generate_weighted_event @ Generate unweighted event. <>= procedure :: generate_unweighted_event => & mci_vamp_generate_unweighted_event <>= subroutine mci_vamp_generate_unweighted_event (mci, instance, sampler) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler class(vamp_data_t), allocatable :: data logical :: positive type(exception) :: vamp_exception select type (instance) type is (mci_vamp_instance_t) instance%vamp_weight_set = .false. allocate (mci_workspace_t :: data) select type (data) type is (mci_workspace_t) data%sampler => sampler data%instance => instance end select select type (rng => mci%rng) type is (rng_tao_t) if (instance%grids_defined) then REJECTION: do call vamp_next_event ( & instance%vamp_x, & rng%state, & instance%grids, & vamp_sampling_function, & data, & phi = phi_trivial, & excess = instance%vamp_excess, & positive = positive, & exc = vamp_exception) if (signal_is_pending ()) return if (sampler%is_valid ()) exit REJECTION end do REJECTION call handle_vamp_exception (vamp_exception, mci%verbose) if (positive) then instance%vamp_weight = 1 else if (instance%negative_weights) then instance%vamp_weight = -1 else call msg_fatal ("VAMP: event with negative weight generated") instance%vamp_weight = 0 end if instance%vamp_weight_set = .true. else call msg_bug ("VAMP: generate event: grids undefined") end if class default call msg_fatal ("VAMP event generation: & &random-number generator must be TAO") end select end select end subroutine mci_vamp_generate_unweighted_event @ %def mci_vamp_generate_unweighted_event @ Rebuild an event, using the [[state]] input. Note: This feature is currently unused. <>= procedure :: rebuild_event => mci_vamp_rebuild_event <>= subroutine mci_vamp_rebuild_event (mci, instance, sampler, state) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state call msg_bug ("MCI vamp rebuild event not implemented yet") end subroutine mci_vamp_rebuild_event @ %def mci_vamp_rebuild_event @ Pacify: override the default no-op, since VAMP numerics might need some massage. <>= procedure :: pacify => mci_vamp_pacify <>= subroutine mci_vamp_pacify (object, efficiency_reset, error_reset) class(mci_vamp_t), intent(inout) :: object logical, intent(in), optional :: efficiency_reset, error_reset logical :: err_reset type(pass_t), pointer :: current_pass err_reset = .false. if (present (error_reset)) err_reset = error_reset current_pass => object%first_pass do while (associated (current_pass)) if (allocated (current_pass%error) .and. err_reset) then current_pass%error = 0 end if if (allocated (current_pass%efficiency) .and. err_reset) then current_pass%efficiency = 1 end if current_pass => current_pass%next end do end subroutine mci_vamp_pacify @ %def mci_vamp_pacify @ \subsection{Sampler as Workspace} In the full setup, the sampling function requires the process instance object as workspace. We implement this by (i) implementing the process instance as a type extension of the abstract [[sampler_t]] object used by the MCI implementation and (ii) providing such an object as an extra argument to the sampling function that VAMP can call. To minimize cross-package dependencies, we use an abstract type [[vamp_workspace]] that VAMP declares and extend this by including a pointer to the [[sampler]] and [[instance]] objects. In the body of the sampling function, we dereference this pointer and can then work with the contents. <>= type, extends (vamp_data_t) :: mci_workspace_t class(mci_sampler_t), pointer :: sampler => null () class(mci_vamp_instance_t), pointer :: instance => null () end type mci_workspace_t @ %def mci_workspace_t @ \subsection{Integrator instance} The history entries should point to the corresponding history entry in the [[pass_t]] object. If there is none, we may allocate a local history, which is then just transient. <>= public :: mci_vamp_instance_t <>= type, extends (mci_instance_t) :: mci_vamp_instance_t type(mci_vamp_t), pointer :: mci => null () logical :: grids_defined = .false. logical :: grids_from_file = .false. integer :: n_it = 0 integer :: it = 0 logical :: pass_complete = .false. integer :: n_calls = 0 integer :: calls = 0 integer :: calls_valid = 0 logical :: it_complete = .false. logical :: enable_adapt_grids = .false. logical :: enable_adapt_weights = .false. logical :: allow_adapt_grids = .false. logical :: allow_adapt_weights = .false. integer :: n_adapt_grids = 0 integer :: n_adapt_weights = 0 logical :: generating_events = .false. real(default) :: safety_factor = 1 type(vamp_grids) :: grids real(default) :: g = 0 real(default), dimension(:), allocatable :: gi real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 real(default), dimension(:), allocatable :: vamp_x logical :: vamp_weight_set = .false. real(default) :: vamp_weight = 0 real(default) :: vamp_excess = 0 logical :: allocate_global_history = .false. type(vamp_history), dimension(:), pointer :: v_history => null () logical :: allocate_channel_history = .false. type(vamp_history), dimension(:,:), pointer :: v_histories => null () contains <> end type mci_vamp_instance_t @ %def mci_vamp_instance_t @ Output. <>= procedure :: write => mci_vamp_instance_write <>= subroutine mci_vamp_instance_write (object, unit, pacify) class(mci_vamp_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u, i character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(3x,A," // FMT_19 // ")") "Integrand = ", object%integrand write (u, "(3x,A," // FMT_19 // ")") "Weight = ", object%mci_weight if (object%vamp_weight_set) then write (u, "(3x,A," // FMT_19 // ")") "VAMP wgt = ", object%vamp_weight if (object%vamp_excess /= 0) then write (u, "(3x,A," // FMT_19 // ")") "VAMP exc = ", & object%vamp_excess end if end if write (u, "(3x,A,L1)") "adapt grids = ", object%enable_adapt_grids write (u, "(3x,A,L1)") "adapt weights = ", object%enable_adapt_weights if (object%grids_defined) then if (object%grids_from_file) then write (u, "(3x,A)") "VAMP grids: read from file" else write (u, "(3x,A)") "VAMP grids: defined" end if else write (u, "(3x,A)") "VAMP grids: [undefined]" end if write (u, "(3x,A,I0)") "n_it = ", object%n_it write (u, "(3x,A,I0)") "it = ", object%it write (u, "(3x,A,L1)") "pass complete = ", object%it_complete write (u, "(3x,A,I0)") "n_calls = ", object%n_calls write (u, "(3x,A,I0)") "calls = ", object%calls write (u, "(3x,A,I0)") "calls_valid = ", object%calls_valid write (u, "(3x,A,L1)") "it complete = ", object%it_complete write (u, "(3x,A,I0)") "n adapt.(g) = ", object%n_adapt_grids write (u, "(3x,A,I0)") "n adapt.(w) = ", object%n_adapt_weights write (u, "(3x,A,L1)") "gen. events = ", object%generating_events write (u, "(3x,A,L1)") "neg. weights = ", object%negative_weights if (object%safety_factor /= 1) write & (u, "(3x,A," // fmt // ")") "safety f = ", object%safety_factor write (u, "(3x,A," // fmt // ")") "integral = ", object%integral write (u, "(3x,A," // fmt // ")") "error = ", object%error write (u, "(3x,A," // fmt // ")") "eff. = ", object%efficiency write (u, "(3x,A)") "weights:" do i = 1, size (object%w) write (u, "(5x,I0,1x," // FMT_12 // ")") i, object%w(i) end do end subroutine mci_vamp_instance_write @ %def mci_vamp_instance_write @ Write the grids to the specified unit. <>= procedure :: write_grids => mci_vamp_instance_write_grids <>= subroutine mci_vamp_instance_write_grids (object, unit) class(mci_vamp_instance_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (object%grids_defined) then call vamp_write_grids (object%grids, u, write_integrals = .true.) end if end subroutine mci_vamp_instance_write_grids @ %def mci_vamp_instance_write_grids @ Finalizer: the history arrays are pointer arrays and need finalization. <>= procedure :: final => mci_vamp_instance_final <>= subroutine mci_vamp_instance_final (object) class(mci_vamp_instance_t), intent(inout) :: object if (object%allocate_global_history) then if (associated (object%v_history)) then call vamp_delete_history (object%v_history) deallocate (object%v_history) end if end if if (object%allocate_channel_history) then if (associated (object%v_histories)) then call vamp_delete_history (object%v_histories) deallocate (object%v_histories) end if end if if (object%grids_defined) then call vamp_delete_grids (object%grids) object%grids_defined = .false. end if end subroutine mci_vamp_instance_final @ %def mci_vamp_instance_final @ Initializer. <>= procedure :: init => mci_vamp_instance_init <>= subroutine mci_vamp_instance_init (mci_instance, mci) class(mci_vamp_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) select type (mci) type is (mci_vamp_t) mci_instance%mci => mci allocate (mci_instance%gi (mci%n_channel)) mci_instance%allocate_global_history = .not. mci%history_par%global mci_instance%allocate_channel_history = .not. mci%history_par%channel mci_instance%negative_weights = mci%negative_weights end select end subroutine mci_vamp_instance_init @ %def mci_vamp_instance_init @ Prepare a new integration pass: write the pass-specific settings to the [[instance]] object. This should be called initially, together with the [[create_grids]] procedure, and whenever we start a new integration pass. Set [[reshape]] if the number of calls is different than previously (unless it was zero, indicating the first pass). We link VAMP histories to the allocated histories in the current pass object, so the recorded results are persistent. However, if there are no histories present there, we allocate them locally. In that case, the histories will disappear together with the MCI instance object. <>= procedure :: new_pass => mci_vamp_instance_new_pass <>= subroutine mci_vamp_instance_new_pass (instance, reshape) class(mci_vamp_instance_t), intent(inout) :: instance logical, intent(out) :: reshape type(pass_t), pointer :: current associate (mci => instance%mci) current => mci%current_pass instance%n_it = current%n_it if (instance%n_calls == 0) then reshape = .false. instance%n_calls = current%n_calls else if (instance%n_calls == current%n_calls) then reshape = .false. else reshape = .true. instance%n_calls = current%n_calls end if instance%it = 0 instance%calls = 0 instance%calls_valid = 0 instance%enable_adapt_grids = current%adapt_grids instance%enable_adapt_weights = current%adapt_weights instance%generating_events = .false. if (instance%allocate_global_history) then if (associated (instance%v_history)) then call vamp_delete_history (instance%v_history) deallocate (instance%v_history) end if allocate (instance%v_history (instance%n_it)) call vamp_create_history (instance%v_history, verbose = .false.) else instance%v_history => current%v_history end if if (instance%allocate_channel_history) then if (associated (instance%v_histories)) then call vamp_delete_history (instance%v_histories) deallocate (instance%v_histories) end if allocate (instance%v_histories (instance%n_it, mci%n_channel)) call vamp_create_history (instance%v_histories, verbose = .false.) else instance%v_histories => current%v_histories end if end associate end subroutine mci_vamp_instance_new_pass @ %def mci_vamp_instance_new_pass @ Create a grid set within the [[instance]] object, using the data of the current integration pass. Also reset counters that track this grid set. <>= procedure :: create_grids => mci_vamp_instance_create_grids <>= subroutine mci_vamp_instance_create_grids (instance) class(mci_vamp_instance_t), intent(inout) :: instance type (pass_t), pointer :: current integer, dimension(:), allocatable :: num_div real(default), dimension(:,:), allocatable :: region associate (mci => instance%mci) current => mci%current_pass allocate (num_div (mci%n_dim)) allocate (region (2, mci%n_dim)) region(1,:) = 0 region(2,:) = 1 num_div = current%n_bins instance%n_adapt_grids = 0 instance%n_adapt_weights = 0 if (.not. instance%grids_defined) then call vamp_create_grids (instance%grids, & region, & current%n_calls, & weights = instance%w, & num_div = num_div, & stratified = mci%grid_par%stratified) instance%grids_defined = .true. else call msg_bug ("VAMP: create grids: grids already defined") end if end associate end subroutine mci_vamp_instance_create_grids @ %def mci_vamp_instance_create_grids @ Reset a grid set, so we can start a fresh integration pass. In effect, we delete results of previous integrations, but keep the grid shapes, weights, and variance arrays, so adaptation is still possible. The grids are prepared for a specific number of calls (per iteration) and sampling mode (stratified/importance). The [[vamp_discard_integrals]] implementation will reshape the grids only if the argument [[num_calls]] is present. <>= procedure :: discard_integrals => mci_vamp_instance_discard_integrals <>= subroutine mci_vamp_instance_discard_integrals (instance, reshape) class(mci_vamp_instance_t), intent(inout) :: instance logical, intent(in) :: reshape instance%calls = 0 instance%calls_valid = 0 instance%integral = 0 instance%error = 0 instance%efficiency = 0 associate (mci => instance%mci) if (instance%grids_defined) then if (mci%grid_par%use_vamp_equivalences) then if (reshape) then call vamp_discard_integrals (instance%grids, & num_calls = instance%n_calls, & stratified = mci%grid_par%stratified, & eq = mci%equivalences) else call vamp_discard_integrals (instance%grids, & stratified = mci%grid_par%stratified, & eq = mci%equivalences) end if else if (reshape) then call vamp_discard_integrals (instance%grids, & num_calls = instance%n_calls, & stratified = mci%grid_par%stratified) else call vamp_discard_integrals (instance%grids, & stratified = mci%grid_par%stratified) end if end if else call msg_bug ("VAMP: discard integrals: grids undefined") end if end associate end subroutine mci_vamp_instance_discard_integrals @ %def mci_vamp_instance_discard_integrals @ After grids are created (with equidistant binning and equal weight), adaptation is redundant. Therefore, we should allow it only after a complete integration step has been performed, calling this. <>= procedure :: allow_adaptation => mci_vamp_instance_allow_adaptation <>= subroutine mci_vamp_instance_allow_adaptation (instance) class(mci_vamp_instance_t), intent(inout) :: instance instance%allow_adapt_grids = .true. instance%allow_adapt_weights = .true. end subroutine mci_vamp_instance_allow_adaptation @ %def mci_vamp_instance_allow_adaptation @ Adapt grids. <>= procedure :: adapt_grids => mci_vamp_instance_adapt_grids <>= subroutine mci_vamp_instance_adapt_grids (instance) class(mci_vamp_instance_t), intent(inout) :: instance if (instance%enable_adapt_grids .and. instance%allow_adapt_grids) then if (instance%grids_defined) then call vamp_refine_grids (instance%grids) instance%n_adapt_grids = instance%n_adapt_grids + 1 else call msg_bug ("VAMP: adapt grids: grids undefined") end if end if end subroutine mci_vamp_instance_adapt_grids @ %def mci_vamp_instance_adapt_grids @ Adapt weights. Use the variance array returned by \vamp\ for recalculating the weight array. The parameter [[channel_weights_power]] dampens fluctuations. If the number of calls in a given channel falls below a user-defined threshold, the weight is not lowered further but kept at this threshold. The other channel weights are reduced accordingly. <>= procedure :: adapt_weights => mci_vamp_instance_adapt_weights <>= subroutine mci_vamp_instance_adapt_weights (instance) class(mci_vamp_instance_t), intent(inout) :: instance real(default) :: w_sum, w_avg_ch, sum_w_underflow, w_min real(default), dimension(:), allocatable :: weights integer :: n_ch, ch, n_underflow logical, dimension(:), allocatable :: mask, underflow type(exception) :: vamp_exception logical :: wsum_non_zero if (instance%enable_adapt_weights .and. instance%allow_adapt_weights) then associate (mci => instance%mci) if (instance%grids_defined) then allocate (weights (size (instance%grids%weights))) weights = instance%grids%weights & * vamp_get_variance (instance%grids%grids) & ** mci%grid_par%channel_weights_power w_sum = sum (weights) if (w_sum /= 0) then weights = weights / w_sum if (mci%n_chain /= 0) then allocate (mask (mci%n_channel)) do ch = 1, mci%n_chain mask = mci%chain == ch n_ch = count (mask) if (n_ch /= 0) then w_avg_ch = sum (weights, mask) / n_ch where (mask) weights = w_avg_ch end if end do end if if (mci%grid_par%threshold_calls /= 0) then w_min = & real (mci%grid_par%threshold_calls, default) & / instance%n_calls allocate (underflow (mci%n_channel)) underflow = weights /= 0 .and. abs (weights) < w_min n_underflow = count (underflow) sum_w_underflow = sum (weights, mask=underflow) if (sum_w_underflow /= 1) then where (underflow) weights = w_min elsewhere weights = weights & * (1 - n_underflow * w_min) / (1 - sum_w_underflow) end where end if end if end if call instance%set_channel_weights (weights, wsum_non_zero) if (wsum_non_zero) call vamp_update_weights & (instance%grids, weights, exc = vamp_exception) call handle_vamp_exception (vamp_exception, mci%verbose) else call msg_bug ("VAMP: adapt weights: grids undefined") end if end associate instance%n_adapt_weights = instance%n_adapt_weights + 1 end if end subroutine mci_vamp_instance_adapt_weights @ %def mci_vamp_instance_adapt_weights @ Integration: sample the VAMP grids. The number of calls etc. are already stored inside the grids. We provide the random-number generator, the sampling function, and a link to the workspace object, which happens to contain a pointer to the sampler object. The sampler object thus becomes the workspace of the sampling function. Note: in the current implementation, the random-number generator must be the TAO generator. This explicit dependence should be removed from the VAMP implementation. <>= procedure :: sample_grids => mci_vamp_instance_sample_grids <>= subroutine mci_vamp_instance_sample_grids (instance, rng, sampler, eq) class(mci_vamp_instance_t), intent(inout), target :: instance class(rng_t), intent(inout) :: rng class(mci_sampler_t), intent(inout), target :: sampler type(vamp_equivalences_t), intent(in), optional :: eq class(vamp_data_t), allocatable :: data type(exception) :: vamp_exception allocate (mci_workspace_t :: data) select type (data) type is (mci_workspace_t) data%sampler => sampler data%instance => instance end select select type (rng) type is (rng_tao_t) instance%it = instance%it + 1 instance%calls = 0 if (instance%grids_defined) then call vamp_sample_grids ( & rng%state, & instance%grids, & vamp_sampling_function, & data, & 1, & eq = eq, & history = instance%v_history(instance%it:), & histories = instance%v_histories(instance%it:,:), & integral = instance%integral, & std_dev = instance%error, & exc = vamp_exception, & negative_weights = instance%negative_weights) call handle_vamp_exception (vamp_exception, instance%mci%verbose) instance%efficiency = instance%get_efficiency () else call msg_bug ("VAMP: sample grids: grids undefined") end if class default call msg_fatal ("VAMP integration: random-number generator must be TAO") end select end subroutine mci_vamp_instance_sample_grids @ %def mci_vamp_instance_sample_grids @ Compute the reweighting efficiency for the current grids, suitable averaged over all active channels. <>= procedure :: get_efficiency_array => mci_vamp_instance_get_efficiency_array procedure :: get_efficiency => mci_vamp_instance_get_efficiency <>= function mci_vamp_instance_get_efficiency_array (mci) result (efficiency) class(mci_vamp_instance_t), intent(in) :: mci real(default), dimension(:), allocatable :: efficiency allocate (efficiency (mci%mci%n_channel)) if (.not. mci%negative_weights) then where (mci%grids%grids%f_max /= 0) efficiency = mci%grids%grids%mu(1) / abs (mci%grids%grids%f_max) elsewhere efficiency = 0 end where else where (mci%grids%grids%f_max /= 0) efficiency = & (mci%grids%grids%mu_plus(1) - mci%grids%grids%mu_minus(1)) & / abs (mci%grids%grids%f_max) elsewhere efficiency = 0 end where end if end function mci_vamp_instance_get_efficiency_array function mci_vamp_instance_get_efficiency (mci) result (efficiency) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: efficiency real(default), dimension(:), allocatable :: weight real(default) :: norm allocate (weight (mci%mci%n_channel)) weight = mci%grids%weights * abs (mci%grids%grids%f_max) norm = sum (weight) if (norm /= 0) then efficiency = dot_product (mci%get_efficiency_array (), weight) / norm else efficiency = 1 end if end function mci_vamp_instance_get_efficiency @ %def mci_vamp_instance_get_efficiency_array @ %def mci_vamp_instance_get_efficiency @ Prepare an event generation pass. Should be called before a sequence of events is generated, then we should call the corresponding finalizer. The pass-specific data of the previous integration pass are retained, but we reset the number of iterations and calls to zero. The latter now counts the number of events (calls to the sampling function, actually). <>= procedure :: init_simulation => mci_vamp_instance_init_simulation <>= subroutine mci_vamp_instance_init_simulation (instance, safety_factor) class(mci_vamp_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor associate (mci => instance%mci) allocate (instance%vamp_x (mci%n_dim)) instance%it = 0 instance%calls = 0 instance%generating_events = .true. if (present (safety_factor)) instance%safety_factor = safety_factor if (.not. instance%grids_defined) then if (mci%grid_filename_set) then if (.not. mci%check_grid_file) & call msg_warning ("Reading grid file: MD5 sum check disabled") call msg_message ("Simulate: " & // "using integration grids from file '" & // char (mci%grid_filename) // "'") call mci%read_grids_data (instance) if (instance%safety_factor /= 1) then write (msg_buffer, "(A,ES10.3,A)") "Simulate: & &applying safety factor", instance%safety_factor, & " to event rejection" call msg_message () instance%grids%grids%f_max = & instance%grids%grids%f_max * instance%safety_factor end if else call msg_bug ("VAMP: simulation: no grids, no grid filename") end if end if end associate end subroutine mci_vamp_instance_init_simulation @ %def mci_vamp_init_simulation @ Finalize an event generation pass. Should be called before a sequence of events is generated, then we should call the corresponding finalizer. <>= procedure :: final_simulation => mci_vamp_instance_final_simulation <>= subroutine mci_vamp_instance_final_simulation (instance) class(mci_vamp_instance_t), intent(inout) :: instance if (allocated (instance%vamp_x)) deallocate (instance%vamp_x) end subroutine mci_vamp_instance_final_simulation @ %def mci_vamp_instance_final_simulation @ \subsection{Sampling function} The VAMP sampling function has a well-defined interface which we have to implement. The [[data]] argument allows us to pass pointers to the [[sampler]] and [[instance]] objects, so we can access configuration data and fill point-dependent contents within these objects. The [[weights]] and [[channel]] argument must be present in the call. Note: this is the place where we must look for external signals, i.e., interrupt from the OS. We would like to raise a \vamp\ exception which is then caught by [[vamp_sample_grids]] as the caller, so it dumps its current state and returns (with the signal still pending). \whizard\ will then terminate gracefully. Of course, VAMP should be able to resume from the dump. In the current implementation, we handle the exception in place and terminate immediately. The incomplete current integration pass is lost. <>= function vamp_sampling_function & (xi, data, weights, channel, grids) result (f) real(default) :: f real(default), dimension(:), intent(in) :: xi class(vamp_data_t), intent(in) :: data real(default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception) :: exc logical :: verbose character(*), parameter :: FN = "WHIZARD sampling function" class(mci_instance_t), pointer :: instance select type (data) type is (mci_workspace_t) instance => data%instance select type (instance) class is (mci_vamp_instance_t) verbose = instance%mci%verbose call instance%evaluate (data%sampler, channel, xi) if (signal_is_pending ()) then call raise_exception (exc, EXC_FATAL, FN, "signal received") call handle_vamp_exception (exc, verbose) call terminate_now_if_signal () end if instance%calls = instance%calls + 1 if (data%sampler%is_valid ()) & & instance%calls_valid = instance%calls_valid + 1 f = instance%get_value () call terminate_now_if_single_event () class default call msg_bug("VAMP: " // FN // ": unknown MCI instance type") end select end select end function vamp_sampling_function @ %def vamp_sampling_function @ This is supposed to be the mapping between integration channels. The VAMP event generating procedures technically require it, but it is meaningless in our setup where all transformations happen inside the sampler object. So, this implementation is trivial: <>= pure 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 phi_trivial @ \subsection{Integrator instance: evaluation} Here, we compute the multi-channel reweighting factor for the current channel, that accounts for the Jacobians of the transformations from/to all other channels. The computation of the VAMP probabilities may consume considerable time, therefore we enable parallel evaluation. (Collecting the contributions to [[mci%g]] is a reduction, which we should also implement via OpenMP.) <>= procedure :: compute_weight => mci_vamp_instance_compute_weight <>= subroutine mci_vamp_instance_compute_weight (mci, c) class(mci_vamp_instance_t), intent(inout) :: mci integer, intent(in) :: c integer :: i mci%selected_channel = c !$OMP PARALLEL PRIVATE(i) SHARED(mci) !$OMP DO do i = 1, mci%mci%n_channel if (mci%w(i) /= 0) then mci%gi(i) = vamp_probability (mci%grids%grids(i), mci%x(:,i)) else mci%gi(i) = 0 end if end do !$OMP END DO !$OMP END PARALLEL mci%g = 0 if (mci%gi(c) /= 0) then do i = 1, mci%mci%n_channel if (mci%w(i) /= 0 .and. mci%f(i) /= 0) then mci%g = mci%g + mci%w(i) * mci%gi(i) / mci%f(i) end if end do end if if (mci%g /= 0) then mci%mci_weight = mci%gi(c) / mci%g else mci%mci_weight = 0 end if end subroutine mci_vamp_instance_compute_weight @ %def mci_vamp_instance_compute_weight @ Record the integrand. <>= procedure :: record_integrand => mci_vamp_instance_record_integrand <>= subroutine mci_vamp_instance_record_integrand (mci, integrand) class(mci_vamp_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand end subroutine mci_vamp_instance_record_integrand @ %def mci_vamp_instance_record_integrand @ Get the event weight. The default routine returns the same value that we would use for integration. This is correct if we select the integration channel according to the channel weight. [[vamp_next_event]] does differently, so we should rather rely on the weight that VAMP returns. This is the value stored in [[vamp_weight]]. We override the default TBP accordingly. <>= procedure :: get_event_weight => mci_vamp_instance_get_event_weight procedure :: get_event_excess => mci_vamp_instance_get_event_excess <>= function mci_vamp_instance_get_event_weight (mci) result (value) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: value if (mci%vamp_weight_set) then value = mci%vamp_weight else call msg_bug ("VAMP: attempt to read undefined event weight") end if end function mci_vamp_instance_get_event_weight function mci_vamp_instance_get_event_excess (mci) result (value) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: value if (mci%vamp_weight_set) then value = mci%vamp_excess else call msg_bug ("VAMP: attempt to read undefined event excess weight") end if end function mci_vamp_instance_get_event_excess @ %def mci_vamp_instance_get_event_excess @ \subsection{VAMP exceptions} A VAMP routine may have raised an exception. Turn this into a WHIZARD error message. An external signal could raise a fatal exception, but this should be delayed and handled by the correct termination routine. <>= subroutine handle_vamp_exception (exc, verbose) type(exception), intent(in) :: exc logical, intent(in) :: verbose integer :: exc_level if (verbose) then exc_level = EXC_INFO else exc_level = EXC_ERROR end if if (exc%level >= exc_level) then write (msg_buffer, "(A,':',1x,A)") trim (exc%origin), trim (exc%message) select case (exc%level) case (EXC_INFO); call msg_message () case (EXC_WARN); call msg_warning () case (EXC_ERROR); call msg_error () case (EXC_FATAL) if (signal_is_pending ()) then call msg_message () else call msg_fatal () end if end select end if end subroutine handle_vamp_exception @ %def handle_vamp_exception @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_vamp_ut.f90]]>>= <> module mci_vamp_ut use unit_tests use mci_vamp_uti <> <> contains <> end module mci_vamp_ut @ %def mci_vamp_ut @ <<[[mci_vamp_uti.f90]]>>= <> module mci_vamp_uti <> <> use io_units use constants, only: PI, TWOPI use rng_base use rng_tao use phs_base use mci_base use vamp, only: vamp_write_grids !NODEP! use mci_vamp <> <> <> contains <> end module mci_vamp_uti @ %def mci_vamp_ut @ API: driver for the unit tests below. <>= public :: mci_vamp_test <>= subroutine mci_vamp_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_vamp_test @ %def mci_vamp_test @ \subsubsection{Test sampler} A test sampler object should implement a function with known integral that we can use to check the integrator. In mode [[1]], the function is $f(x) = 3 x^2$ with integral $\int_0^1 f(x)\,dx=1$ and maximum $f(1)=3$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). In mode [[2]], the function is $11 x^{10}$, also with integral $1$. Mode [[4]] includes ranges of zero and negative function value, the integral is negative. The results should be identical to the results of [[mci_midpoint_4]], where the same function is evaluated. The function is $f(x) = (1 - 3 x^2)\,\theta(x-1/2)$ with integral $\int_0^1 f(x)\,dx=-3/8$, minimum $f(1)=-2$ and maximum $f(1/2)=1/4$. <>= type, extends (mci_sampler_t) :: test_sampler_1_t real(default), dimension(:), allocatable :: x real(default) :: val integer :: mode = 1 contains <> end type test_sampler_1_t @ %def test_sampler_1_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_1_write <>= subroutine test_sampler_1_write (object, unit, testflag) class(test_sampler_1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) select case (object%mode) case (1) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2" case (2) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10" case (3) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10 * 2 * cos^2 (2 pi y)" case (4) write (u, "(1x,A)") "Test sampler: f(x) = (1 - 3 x^2) theta(x - 1/2)" end select end subroutine test_sampler_1_write @ %def test_sampler_1_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_1_evaluate <>= subroutine test_sampler_1_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in select case (sampler%mode) case (1) sampler%val = 3 * x_in(1) ** 2 case (2) sampler%val = 11 * x_in(1) ** 10 case (3) sampler%val = 11 * x_in(1) ** 10 * 2 * cos (twopi * x_in(2)) ** 2 case (4) if (x_in(1) >= .5_default) then sampler%val = 1 - 3 * x_in(1) ** 2 else sampler%val = 0 end if end select call sampler%fetch (val, x, f) end subroutine test_sampler_1_evaluate @ %def test_sampler_1_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_1_is_valid <>= function test_sampler_1_is_valid (sampler) result (valid) class(test_sampler_1_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_1_is_valid @ %def test_sampler_1_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_1_rebuild <>= subroutine test_sampler_1_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_rebuild @ %def test_sampler_1_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_1_fetch <>= subroutine test_sampler_1_fetch (sampler, val, x, f) class(test_sampler_1_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_fetch @ %def test_sampler_1_fetch @ \subsubsection{Two-channel, two dimension test sampler} This sampler implements the function \begin{equation} f(x, y) = 4\sin^2(\pi x)\sin^2(\pi y) + 2\sin^2(\pi v) \end{equation} where \begin{align} x &= u^v &u &= xy \\ y &= u^{(1-v)} &v &= \frac12\left(1 + \frac{\log(x/y)}{\log xy}\right) \end{align} Each term contributes $1$ to the integral. The first term in the function is peaked along a cross aligned to the coordinates $x$ and $y$, while the second term is peaked along the diagonal $x=y$. The Jacobian is \begin{equation} \frac{\partial(x,y)}{\partial(u,v)} = |\log u| \end{equation} <>= type, extends (mci_sampler_t) :: test_sampler_2_t real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f real(default) :: val contains <> end type test_sampler_2_t @ %def test_sampler_2_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_2_write <>= subroutine test_sampler_2_write (object, unit, testflag) class(test_sampler_2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Two-channel test sampler 2" end subroutine test_sampler_2_write @ %def test_sampler_2_write @ Kinematics: compute $x$ and Jacobians, given the input parameter array. <>= procedure :: compute => test_sampler_2_compute <>= subroutine test_sampler_2_compute (sampler, c, x_in) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default) :: xx, yy, uu, vv if (.not. allocated (sampler%x)) & allocate (sampler%x (size (x_in), 2)) if (.not. allocated (sampler%f)) & allocate (sampler%f (2)) select case (c) case (1) xx = x_in(1) yy = x_in(2) uu = xx * yy vv = (1 + log (xx/yy) / log (xx*yy)) / 2 case (2) uu = x_in(1) vv = x_in(2) xx = uu ** vv yy = uu ** (1 - vv) end select sampler%val = (2 * sin (pi * xx) * sin (pi * yy)) ** 2 & + 2 * sin (pi * vv) ** 2 sampler%f(1) = 1 sampler%f(2) = abs (log (uu)) sampler%x(:,1) = [xx, yy] sampler%x(:,2) = [uu, vv] end subroutine test_sampler_2_compute @ %def test_sampler_kinematics @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_2_evaluate <>= subroutine test_sampler_2_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) call sampler%fetch (val, x, f) end subroutine test_sampler_2_evaluate @ %def test_sampler_2_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_2_is_valid <>= function test_sampler_2_is_valid (sampler) result (valid) class(test_sampler_2_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_2_is_valid @ %def test_sampler_2_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_2_rebuild <>= subroutine test_sampler_2_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) x = sampler%x f = sampler%f end subroutine test_sampler_2_rebuild @ %def test_sampler_2_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_2_fetch <>= subroutine test_sampler_2_fetch (sampler, val, x, f) class(test_sampler_2_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x = sampler%x f = sampler%f end subroutine test_sampler_2_fetch @ %def test_sampler_2_fetch @ \subsubsection{Two-channel, one dimension test sampler} This sampler implements the function \begin{equation} f(x, y) = a * 5 x^4 + b * 5 (1-x)^4 \end{equation} Each term contributes $1$ to the integral, multiplied by $a$ or $b$, respectively. The first term is peaked at $x=1$, the second one at $x=0$.. We implement the two mappings \begin{equation} x = u^{1/5} \quad\text{and}\quad x = 1 - v^{1/5}, \end{equation} with Jacobians \begin{equation} \frac{\partial(x)}{\partial(u)} = u^{-4/5}/5 \quad\text{and}\quad v^{-4/5}/5, \end{equation} respectively. The first mapping concentrates points near $x=1$, the second one near $x=0$. <>= type, extends (mci_sampler_t) :: test_sampler_3_t real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f real(default) :: val real(default) :: a = 1 real(default) :: b = 1 contains <> end type test_sampler_3_t @ %def test_sampler_3_t @ Output: display $a$ and $b$ <>= procedure :: write => test_sampler_3_write <>= subroutine test_sampler_3_write (object, unit, testflag) class(test_sampler_3_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Two-channel test sampler 3" write (u, "(3x,A,F5.2)") "a = ", object%a write (u, "(3x,A,F5.2)") "b = ", object%b end subroutine test_sampler_3_write @ %def test_sampler_3_write @ Kinematics: compute $x$ and Jacobians, given the input parameter array. <>= procedure :: compute => test_sampler_3_compute <>= subroutine test_sampler_3_compute (sampler, c, x_in) class(test_sampler_3_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default) :: u, v, xx if (.not. allocated (sampler%x)) & allocate (sampler%x (size (x_in), 2)) if (.not. allocated (sampler%f)) & allocate (sampler%f (2)) select case (c) case (1) u = x_in(1) xx = u ** 0.2_default v = (1 - xx) ** 5._default case (2) v = x_in(1) xx = 1 - v ** 0.2_default u = xx ** 5._default end select sampler%val = sampler%a * 5 * xx ** 4 + sampler%b * 5 * (1 - xx) ** 4 sampler%f(1) = 0.2_default * u ** (-0.8_default) sampler%f(2) = 0.2_default * v ** (-0.8_default) sampler%x(:,1) = [u] sampler%x(:,2) = [v] end subroutine test_sampler_3_compute @ %def test_sampler_kineamtics @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_3_evaluate <>= subroutine test_sampler_3_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_3_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) call sampler%fetch (val, x, f) end subroutine test_sampler_3_evaluate @ %def test_sampler_3_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_3_is_valid <>= function test_sampler_3_is_valid (sampler) result (valid) class(test_sampler_3_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_3_is_valid @ %def test_sampler_3_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_3_rebuild <>= subroutine test_sampler_3_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_3_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) x = sampler%x f = sampler%f end subroutine test_sampler_3_rebuild @ %def test_sampler_3_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_3_fetch <>= subroutine test_sampler_3_fetch (sampler, val, x, f) class(test_sampler_3_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x = sampler%x f = sampler%f end subroutine test_sampler_3_fetch @ %def test_sampler_3_fetch @ \subsubsection{One-dimensional integration} Construct an integrator and use it for a one-dimensional sampler. Note: We would like to check the precise contents of the grid allocated during integration, but the output format for reals is very long (for good reasons), so the last digits in the grid content display are numerical noise. So, we just check the integration results. <>= call test (mci_vamp_1, "mci_vamp_1", & "one-dimensional integral", & u, results) <>= public :: mci_vamp_1 <>= subroutine mci_vamp_1 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_1" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") " (lower precision to avoid" write (u, "(A)") " numerical noise)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 1, 1000, pacify = .true.) call mci%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_1" end subroutine mci_vamp_1 @ %def mci_vamp_1 @ \subsubsection{Multiple iterations} Construct an integrator and use it for a one-dimensional sampler. Integrate with five iterations without grid adaptation. <>= call test (mci_vamp_2, "mci_vamp_2", & "multiple iterations", & u, results) <>= public :: mci_vamp_2 <>= subroutine mci_vamp_2 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_2" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .false.) end select call mci%integrate (mci_instance, sampler, 3, 100) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_2" end subroutine mci_vamp_2 @ %def mci_vamp_2 @ \subsubsection{Grid adaptation} Construct an integrator and use it for a one-dimensional sampler. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp_3, "mci_vamp_3", & "grid adaptation", & u, results) <>= public :: mci_vamp_3 <>= subroutine mci_vamp_3 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_3" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 100) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_3" end subroutine mci_vamp_3 @ %def mci_vamp_3 @ \subsubsection{Two-dimensional integral} Construct an integrator and use it for a two-dimensional sampler. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp_4, "mci_vamp_4", & "two-dimensional integration", & u, results) <>= public :: mci_vamp_4 <>= subroutine mci_vamp_4 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_4" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(single channel)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 3 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_4" end subroutine mci_vamp_4 @ %def mci_vamp_4 @ \subsubsection{Two-channel integral} Construct an integrator and use it for a two-dimensional sampler with two channels. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp_5, "mci_vamp_5", & "two-dimensional integration", & u, results) <>= public :: mci_vamp_5 <>= subroutine mci_vamp_5 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_5" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_5" end subroutine mci_vamp_5 @ %def mci_vamp_5 @ \subsubsection{Weight adaptation} Construct an integrator and use it for a one-dimensional sampler with two channels. Integrate with three iterations and in-between weight adaptations. <>= call test (mci_vamp_6, "mci_vamp_6", & "weight adaptation", & u, results) <>= public :: mci_vamp_6 <>= subroutine mci_vamp_6 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_6" write (u, "(A)") "* Purpose: integrate function in one dimension & &(two channels)" write (u, "(A)") "* and adapt weights" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.9_default sampler%b = 0.1_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () deallocate (mci_instance) deallocate (mci) write (u, "(A)") write (u, "(A)") "* Re-initialize with chained channels" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) call mci%declare_chains ([1,1]) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_6" end subroutine mci_vamp_6 @ %def mci_vamp_6 @ \subsubsection{Equivalences} Construct an integrator and use it for a one-dimensional sampler with two channels. Integrate with three iterations and in-between grid adaptations. Apply an equivalence between the two channels, so the binning of the two channels is forced to coincide. Compare this with the behavior without equivalences. <>= call test (mci_vamp_7, "mci_vamp_7", & "use channel equivalences", & u, results) <>= public :: mci_vamp_7 <>= subroutine mci_vamp_7 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler type(phs_channel_t), dimension(:), allocatable :: channel class(rng_t), allocatable :: rng real(default), dimension(:,:), allocatable :: x integer :: u_grid, iostat, i, div, ch character(16) :: buffer write (u, "(A)") "* Test output: mci_vamp_7" write (u, "(A)") "* Purpose: check effect of channel equivalences" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.7_default sampler%b = 0.3_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 2 and n_calls = 1000, & &adapt grids" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 2, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Write grids and extract binning" write (u, "(A)") u_grid = free_unit () open (u_grid, status = "scratch", action = "readwrite") select type (mci_instance) type is (mci_vamp_instance_t) call vamp_write_grids (mci_instance%grids, u_grid) end select rewind (u_grid) allocate (x (0:20, 2)) do div = 1, 2 FIND_BINS1: do read (u_grid, "(A)") buffer if (trim (adjustl (buffer)) == "begin d%x") then do read (u_grid, *, iostat = iostat) i, x(i,div) if (iostat /= 0) exit FIND_BINS1 end do end if end do FIND_BINS1 end do close (u_grid) write (u, "(1x,A,L1)") "Equal binning in both channels = ", & all (x(:,1) == x(:,2)) deallocate (x) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () deallocate (mci_instance) deallocate (mci) write (u, "(A)") write (u, "(A)") "* Re-initialize integrator, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .true. call mci%set_grid_parameters (grid_par) end select write (u, "(A)") "* Define equivalences" write (u, "(A)") allocate (channel (2)) do ch = 1, 2 allocate (channel(ch)%eq (2)) do i = 1, 2 associate (eq => channel(ch)%eq(i)) call eq%init (1) eq%c = i eq%perm = [1] eq%mode = [0] end associate end do write (u, "(1x,I0,':')", advance = "no") ch call channel(ch)%write (u) end do call mci%declare_equivalences (channel, dim_offset = 0) allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 2 and n_calls = 1000, & &adapt grids" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 2, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Write grids and extract binning" write (u, "(A)") u_grid = free_unit () open (u_grid, status = "scratch", action = "readwrite") select type (mci_instance) type is (mci_vamp_instance_t) call vamp_write_grids (mci_instance%grids, u_grid) end select rewind (u_grid) allocate (x (0:20, 2)) do div = 1, 2 FIND_BINS2: do read (u_grid, "(A)") buffer if (trim (adjustl (buffer)) == "begin d%x") then do read (u_grid, *, iostat = iostat) i, x(i,div) if (iostat /= 0) exit FIND_BINS2 end do end if end do FIND_BINS2 end do close (u_grid) write (u, "(1x,A,L1)") "Equal binning in both channels = ", & all (x(:,1) == x(:,2)) deallocate (x) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_7" end subroutine mci_vamp_7 @ %def mci_vamp_7 @ \subsubsection{Multiple passes} Integrate with three passes and different settings for weight and grid adaptation. <>= call test (mci_vamp_8, "mci_vamp_8", & "integration passes", & u, results) <>= public :: mci_vamp_8 <>= subroutine mci_vamp_8 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_8" write (u, "(A)") "* Purpose: integrate function in one dimension & &(two channels)" write (u, "(A)") "* in three passes" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.9_default sampler%b = 0.1_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with grid and weight adaptation" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true., adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with grid adaptation" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate without adaptation" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_8" end subroutine mci_vamp_8 @ %def mci_vamp_8 @ \subsubsection{Weighted events} Construct an integrator and use it for a two-dimensional sampler with two channels. Integrate and generate a weighted event. <>= call test (mci_vamp_9, "mci_vamp_9", & "weighted event", & u, results) <>= public :: mci_vamp_9 <>= subroutine mci_vamp_9 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_9" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and generate a weighted event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Generate a weighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_weighted_event (mci_instance, sampler) write (u, "(1x,A)") "MCI instance:" call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final_simulation () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_9" end subroutine mci_vamp_9 @ %def mci_vamp_9 @ \subsubsection{Grids I/O} Construct an integrator and allocate grids. Write grids to file, read them in again and compare. <>= call test (mci_vamp_10, "mci_vamp_10", & "grids I/O", & u, results) <>= public :: mci_vamp_10 <>= subroutine mci_vamp_10 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng type(string_t) :: file1, file2 character(80) :: buffer1, buffer2 integer :: u1, u2, iostat1, iostat2 logical :: equal, success write (u, "(A)") "* Test output: mci_vamp_10" write (u, "(A)") "* Purpose: write and read VAMP grids" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) mci%md5sum = "1234567890abcdef1234567890abcdef" call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) write (u, "(A)") "* Write grids to file" write (u, "(A)") file1 = "mci_vamp_10.1" select type (mci) type is (mci_vamp_t) call mci%set_grid_filename (file1) call mci%write_grids (mci_instance) end select call mci_instance%final () call mci%final () deallocate (mci) write (u, "(A)") "* Read grids from file" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) mci%md5sum = "1234567890abcdef1234567890abcdef" call mci%allocate_instance (mci_instance) call mci_instance%init (mci) select type (mci) type is (mci_vamp_t) call mci%set_grid_filename (file1) call mci%add_pass () call mci%current_pass%configure (1, 1000, & mci%min_calls, & mci%grid_par%min_bins, mci%grid_par%max_bins, & mci%grid_par%min_calls_per_channel * mci%n_channel) call mci%read_grids_header (success) call mci%compute_md5sum () call mci%read_grids_data (mci_instance, read_integrals = .true.) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") write (u, "(A)") "* Write grids again" write (u, "(A)") file2 = "mci_vamp_10.2" select type (mci) type is (mci_vamp_t) call mci%set_grid_filename (file2) call mci%write_grids (mci_instance) end select u1 = free_unit () open (u1, file = char (file1) // ".vg", action = "read", status = "old") u2 = free_unit () open (u2, file = char (file2) // ".vg", action = "read", status = "old") equal = .true. iostat1 = 0 iostat2 = 0 do while (equal .and. iostat1 == 0 .and. iostat2 == 0) read (u1, "(A)", iostat = iostat1) buffer1 read (u2, "(A)", iostat = iostat2) buffer2 equal = buffer1 == buffer2 .and. iostat1 == iostat2 end do close (u1) close (u2) if (equal) then write (u, "(1x,A)") "Success: grid files are identical" else write (u, "(1x,A)") "Failure: grid files differ" end if write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_10" end subroutine mci_vamp_10 @ %def mci_vamp_10 @ \subsubsection{Weighted events with grid I/O} Construct an integrator and use it for a two-dimensional sampler with two channels. Integrate, write grids, and generate a weighted event using the grids from file. <>= call test (mci_vamp_11, "mci_vamp_11", & "weighted events with grid I/O", & u, results) <>= public :: mci_vamp_11 <>= subroutine mci_vamp_11 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_11" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and generate a weighted event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) call mci%set_grid_filename (var_str ("mci_vamp_11")) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) write (u, "(A)") "* Reset instance" write (u, "(A)") call mci_instance%final () call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Generate a weighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_weighted_event (mci_instance, sampler) write (u, "(A)") "* Cleanup" call mci_instance%final_simulation () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_11" end subroutine mci_vamp_11 @ %def mci_vamp_11 @ \subsubsection{Unweighted events with grid I/O} Construct an integrator and use it for a two-dimensional sampler with two channels. <>= call test (mci_vamp_12, "mci_vamp_12", & "unweighted events with grid I/O", & u, results) <>= public :: mci_vamp_12 <>= subroutine mci_vamp_12 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_12" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and generate an unweighted event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) call mci%set_grid_filename (var_str ("mci_vamp_12")) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) write (u, "(A)") "* Reset instance" write (u, "(A)") call mci_instance%final () call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Generate an unweighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_unweighted_event (mci_instance, sampler) write (u, "(1x,A)") "MCI instance:" call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final_simulation () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_12" end subroutine mci_vamp_12 @ %def mci_vamp_12 @ \subsubsection{Update integration results} Compare two [[mci]] objects; match the two and update the first if successful. <>= call test (mci_vamp_13, "mci_vamp_13", & "updating integration results", & u, results) <>= public :: mci_vamp_13 <>= subroutine mci_vamp_13 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci, mci_ref logical :: success write (u, "(A)") "* Test output: mci_vamp_13" write (u, "(A)") "* Purpose: match and update integrators" write (u, "(A)") write (u, "(A)") "* Initialize integrator with no passes" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize reference" write (u, "(A)") allocate (mci_vamp_t :: mci_ref) call mci_ref%set_dimensions (2, 2) select type (mci_ref) type is (mci_vamp_t) call mci_ref%set_grid_parameters (grid_par) end select select type (mci_ref) type is (mci_vamp_t) call mci_ref%add_pass (adapt_grids = .true.) call mci_ref%current_pass%configure (2, 1000, 0, 1, 5, 0) mci_ref%current_pass%calls = [77, 77] mci_ref%current_pass%integral = [1.23_default, 3.45_default] mci_ref%current_pass%error = [0.23_default, 0.45_default] mci_ref%current_pass%efficiency = [0.1_default, 0.6_default] mci_ref%current_pass%integral_defined = .true. call mci_ref%add_pass () call mci_ref%current_pass%configure (2, 2000, 0, 1, 7, 0) mci_ref%current_pass%calls = [99, 0] mci_ref%current_pass%integral = [7.89_default, 0._default] mci_ref%current_pass%error = [0.89_default, 0._default] mci_ref%current_pass%efficiency = [0.86_default, 0._default] mci_ref%current_pass%integral_defined = .true. end select call mci_ref%write (u) write (u, "(A)") write (u, "(A)") "* Update integrator (no-op, should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Add pass to integrator" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) call mci%current_pass%configure (2, 1000, 0, 1, 5, 0) mci%current_pass%calls = [77, 77] mci%current_pass%integral = [1.23_default, 3.45_default] mci%current_pass%error = [0.23_default, 0.45_default] mci%current_pass%efficiency = [0.1_default, 0.6_default] mci%current_pass%integral_defined = .true. end select write (u, "(A)") "* Update integrator (no-op, should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Add pass to integrator, wrong parameters" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () call mci%current_pass%configure (2, 1000, 0, 1, 7, 0) end select write (u, "(A)") "* Update integrator (should fail)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Reset and add passes to integrator" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%reset () call mci%add_pass (adapt_grids = .true.) call mci%current_pass%configure (2, 1000, 0, 1, 5, 0) mci%current_pass%calls = [77, 77] mci%current_pass%integral = [1.23_default, 3.45_default] mci%current_pass%error = [0.23_default, 0.45_default] mci%current_pass%efficiency = [0.1_default, 0.6_default] mci%current_pass%integral_defined = .true. call mci%add_pass () call mci%current_pass%configure (2, 2000, 0, 1, 7, 0) end select write (u, "(A)") "* Update integrator (should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Update again (no-op, should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Add extra result to integrator" write (u, "(A)") select type (mci) type is (mci_vamp_t) mci%current_pass%calls(2) = 1234 end select write (u, "(A)") "* Update integrator (should fail)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci%final () call mci_ref%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_13" end subroutine mci_vamp_13 @ %def mci_vamp_13 @ \subsubsection{Accuracy Goal} Integrate with multiple iterations. Skip iterations once an accuracy goal has been reached. <>= call test (mci_vamp_14, "mci_vamp_14", & "accuracy goal", & u, results) <>= public :: mci_vamp_14 <>= subroutine mci_vamp_14 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_14" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") "* and check accuracy goal" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. grid_par%accuracy_goal = 5E-2_default call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 5 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 5, 100) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_14" end subroutine mci_vamp_14 @ %def mci_vamp_14 @ \subsubsection{VAMP history} Integrate with three passes and different settings for weight and grid adaptation. Then show the VAMP history. <>= call test (mci_vamp_15, "mci_vamp_15", & "VAMP history", & u, results) <>= public :: mci_vamp_15 <>= subroutine mci_vamp_15 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par type(history_parameters_t) :: history_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_15" write (u, "(A)") "* Purpose: integrate function in one dimension & &(two channels)" write (u, "(A)") "* in three passes, show history" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") history_par%channel = .true. allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) call mci%set_history_parameters (history_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.9_default sampler%b = 0.1_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Pass 1: grid and weight adaptation" select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true., adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) write (u, "(A)") write (u, "(A)") "* Pass 2: grid adaptation" select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) write (u, "(A)") write (u, "(A)") "* Pass 3: without adaptation" select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 3, 1000) write (u, "(A)") write (u, "(A)") "* Contents of MCI record, with history" write (u, "(A)") call mci%write (u) select type (mci) type is (mci_vamp_t) call mci%write_history (u) end select write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_15" end subroutine mci_vamp_15 @ %def mci_vamp_15 @ \subsubsection{One-dimensional integration with sign change} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_vamp_16, "mci_vamp_16", & "1-D integral with sign change", & u, results) <>= public :: mci_vamp_16 <>= subroutine mci_vamp_16 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_16" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) mci%negative_weights = .true. end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 4 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") " (lower precision to avoid" write (u, "(A)") " numerical noise)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 1, 1000, pacify = .true.) call mci%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_16" end subroutine mci_vamp_16 @ %def mci_vamp_16 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Multi-channel integration with VAMP2} \label{sec:vegas-integration} The multi-channel integration uses VEGAS as backbone integrator. The base interface for the multi-channel integration is given by [[mci_base]] module. We interface the VAMP2 interface given by [[vamp2]] module. <<[[mci_vamp2.f90]]>>= <> module mci_vamp2 <> <> use io_units use format_utils, only: pac_fmt use format_utils, only: write_separator, write_indent use format_defs, only: FMT_12, FMT_14, FMT_17, FMT_19 use constants, only: tiny_13 use diagnostics use md5 use phs_base use rng_base use os_interface, only: mpi_get_comm_id use rng_stream, only: rng_stream_t use mci_base use vegas, only: VEGAS_MODE_IMPORTANCE, VEGAS_MODE_IMPORTANCE_ONLY use vamp2 <> <> <> <> <> contains <> end module mci_vamp2 @ %def mci_vamp2 <>= @ <>= use mpi_f08 !NODEP! @ %def mpi_f08 @ \subsection{Type: mci\_vamp2\_func\_t} \label{sec:mci-vamp2-func} <>= type, extends (vamp2_func_t) :: mci_vamp2_func_t private real(default) :: integrand = 0. class(mci_sampler_t), pointer :: sampler => null () class(mci_vamp2_instance_t), pointer :: instance => null () contains <> end type mci_vamp2_func_t @ %def mci_vamp2_func_t @ Set instance and sampler aka workspace. Also, reset number of [[n_calls]]. <>= procedure, public :: set_workspace => mci_vamp2_func_set_workspace <>= subroutine mci_vamp2_func_set_workspace (self, instance, sampler) class(mci_vamp2_func_t), intent(inout) :: self class(mci_vamp2_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler self%instance => instance self%sampler => sampler end subroutine mci_vamp2_func_set_workspace @ %def mci_vamp2_func_set_workspace @ Get the different channel probabilities. <>= procedure, public :: get_probabilities => mci_vamp2_func_get_probabilities <>= function mci_vamp2_func_get_probabilities (self) result (gi) class(mci_vamp2_func_t), intent(inout) :: self real(default), dimension(self%n_channel) :: gi gi = self%gi end function mci_vamp2_func_get_probabilities @ %def mci_vamp2_func_get_probabilities @ Get multi-channel weight. <>= procedure, public :: get_weight => mci_vamp2_func_get_weight <>= real(default) function mci_vamp2_func_get_weight (self) result (g) class(mci_vamp2_func_t), intent(in) :: self g = self%g end function mci_vamp2_func_get_weight @ %def mci_vamp2_func_get_weight @ Set integrand. <>= procedure, public :: set_integrand => mci_vamp2_func_set_integrand <>= subroutine mci_vamp2_func_set_integrand (self, integrand) class(mci_vamp2_func_t), intent(inout) :: self real(default), intent(in) :: integrand self%integrand = integrand end subroutine mci_vamp2_func_set_integrand @ %def mci_vamp2_func_set_integrand @ Evaluate the mappings. <>= procedure, public :: evaluate_maps => mci_vamp2_func_evaluate_maps <>= subroutine mci_vamp2_func_evaluate_maps (self, x) class(mci_vamp2_func_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x select type (self) type is (mci_vamp2_func_t) call self%instance%evaluate (self%sampler, self%current_channel, x) end select self%valid_x = self%instance%valid self%xi = self%instance%x self%det = self%instance%f end subroutine mci_vamp2_func_evaluate_maps @ %def mci_vamp2_func_evaluate_maps @ Evaluate the function, more or less. <>= procedure, public :: evaluate_func => mci_vamp2_func_evaluate_func <>= real(default) function mci_vamp2_func_evaluate_func (self, x) result (f) class(mci_vamp2_func_t), intent(in) :: self real(default), dimension(:), intent(in) :: x f = self%integrand if (signal_is_pending ()) then call msg_message ("VAMP2: function evaluate_func: signal received") call terminate_now_if_signal () end if call terminate_now_if_single_event () end function mci_vamp2_func_evaluate_func @ %def mci_vamp2_func_evaluate_func @ \subsection{Type: mci\_vamp2\_config\_t} We extend [[vamp2_config_t]]. <>= public :: mci_vamp2_config_t <>= type, extends (vamp2_config_t) :: mci_vamp2_config_t ! end type mci_vamp2_config_t @ %def mci_vamp2_config_t @ \subsection{Integration pass} The list of passes is organized in a separate container. We store the parameters and results for each integration pass in [[pass_t]] and the linked list is stored in [[list_pass_t]]. <>= type :: list_pass_t type(pass_t), pointer :: first => null () type(pass_t), pointer :: current => null () contains <> end type list_pass_t @ %def list_pass_t @ Finalizer. Deallocate each element of the list beginning by the first. <>= procedure :: final => list_pass_final <>= subroutine list_pass_final (self) class(list_pass_t), intent(inout) :: self type(pass_t), pointer :: current current => self%first do while (associated (current)) self%first => current%next deallocate (current) current => self%first end do end subroutine list_pass_final @ %def pass_final @ Add a new pass. <>= procedure :: add => list_pass_add <>= subroutine list_pass_add (self, adapt_grids, adapt_weights, final_pass) class(list_pass_t), intent(inout) :: self logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass type(pass_t), pointer :: new_pass allocate (new_pass) new_pass%i_pass = 1 new_pass%i_first_it = 1 new_pass%adapt_grids = .false.; if (present (adapt_grids)) & & new_pass%adapt_grids = adapt_grids new_pass%adapt_weights = .false.; if (present (adapt_weights)) & & new_pass%adapt_weights = adapt_weights new_pass%is_final_pass = .false.; if (present (final_pass)) & & new_pass%is_final_pass = final_pass if (.not. associated (self%first)) then self%first => new_pass else new_pass%i_pass = new_pass%i_pass + self%current%i_pass new_pass%i_first_it = self%current%i_first_it + self%current%n_it self%current%next => new_pass end if self%current => new_pass end subroutine list_pass_add @ %def list_pass_add @ Update list from a reference. All passes except for the last one must match exactly. For the last one, integration results are updated. The reference output may contain extra passes, these are ignored. <>= procedure :: update_from_ref => list_pass_update_from_ref <>= subroutine list_pass_update_from_ref (self, ref, success) class(list_pass_t), intent(inout) :: self type(list_pass_t), intent(in) :: ref logical, intent(out) :: success type(pass_t), pointer :: current, ref_current current => self%first ref_current => ref%first success = .true. do while (success .and. associated (current)) if (associated (ref_current)) then if (associated (current%next)) then success = current .matches. ref_current else call current%update (ref_current, success) end if current => current%next ref_current => ref_current%next else success = .false. end if end do end subroutine list_pass_update_from_ref @ %def list_pass_update_from_ref <>= procedure :: has_last_integral => list_pass_has_last_integral procedure :: get_last_integral => list_pass_get_last_integral <>= function list_pass_has_last_integral(self) result (flag) class(list_pass_t), intent(in) :: self logical :: flag flag = associated(self%current) if (flag) flag = self%current%integral_defined end function list_pass_has_last_integral subroutine list_pass_get_last_integral(self, integral, error, efficiency) class(list_pass_t), intent(in) :: self real(default), intent(out) :: integral real(default), intent(out) :: error real(default), intent(out) :: efficiency if (self%has_last_integral()) then integral = self%current%get_integral() error = self%current%get_error() efficiency = self%current%get_efficiency() else integral = 0 error = 0 efficiency = 0 end if end subroutine list_pass_get_last_integral @ %def list_pass_has_last_integral list_pass_get_last_integral @ Output. Write the complete linked list to the specified unit. <>= procedure :: write => list_pass_write <>= subroutine list_pass_write (self, unit, pacify) class(list_pass_t), intent(in) :: self integer, intent(in) :: unit logical, intent(in), optional :: pacify type(pass_t), pointer :: current current => self%first do while (associated (current)) write (unit, "(1X,A)") "Integration pass:" call current%write (unit, pacify) current => current%next end do end subroutine list_pass_write @ %def list_pass_write @ The parameters and results are stored in the nodes [[pass_t]] of the linked list. <>= type :: pass_t integer :: i_pass = 0 integer :: i_first_it = 0 integer :: n_it = 0 integer :: n_calls = 0 logical :: adapt_grids = .false. logical :: adapt_weights = .false. logical :: is_final_pass = .false. logical :: integral_defined = .false. integer, dimension(:), allocatable :: calls integer, dimension(:), allocatable :: calls_valid real(default), dimension(:), allocatable :: integral real(default), dimension(:), allocatable :: error real(default), dimension(:), allocatable :: efficiency type(pass_t), pointer :: next => null () contains <> end type pass_t @ %def pass_t @ Output. Note that the precision of the numerical values should match the precision for comparing output from file with data. <>= procedure :: write => pass_write <>= subroutine pass_write (self, unit, pacify) class(pass_t), intent(in) :: self integer, intent(in) :: unit logical, intent(in), optional :: pacify integer :: u, i real(default) :: pac_error character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(3X,A,I0)") "n_it = ", self%n_it write (u, "(3X,A,I0)") "n_calls = ", self%n_calls write (u, "(3X,A,L1)") "adapt grids = ", self%adapt_grids write (u, "(3X,A,L1)") "adapt weights = ", self%adapt_weights if (self%integral_defined) then write (u, "(3X,A)") "Results: [it, calls, valid, integral, error, efficiency]" do i = 1, self%n_it if (abs (self%error(i)) > tiny_13) then pac_error = self%error(i) else pac_error = 0 end if write (u, "(5x,I0,2(1x,I0),3(1x," // fmt // "))") & i, self%calls(i), self%calls_valid(i), self%integral(i), & pac_error, self%efficiency(i) end do else write (u, "(3x,A)") "Results: [undefined]" end if end subroutine pass_write @ %def pass_write @ Read and reconstruct the pass. <>= procedure :: read => pass_read <>= subroutine pass_read (self, u, n_pass, n_it) class(pass_t), intent(out) :: self integer, intent(in) :: u, n_pass, n_it integer :: i, j character(80) :: buffer self%i_pass = n_pass + 1 self%i_first_it = n_it + 1 call read_ival (u, self%n_it) call read_ival (u, self%n_calls) call read_lval (u, self%adapt_grids) call read_lval (u, self%adapt_weights) allocate (self%calls (self%n_it), source = 0) allocate (self%calls_valid (self%n_it), source = 0) allocate (self%integral (self%n_it), source = 0._default) allocate (self%error (self%n_it), source = 0._default) allocate (self%efficiency (self%n_it), source = 0._default) read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("Results: [it, calls, valid, integral, error, efficiency]") do i = 1, self%n_it read (u, *) & j, self%calls(i), self%calls_valid(i), self%integral(i), self%error(i), & self%efficiency(i) end do self%integral_defined = .true. case ("Results: [undefined]") self%integral_defined = .false. case default call msg_fatal ("Reading integration pass: corrupted file") end select end subroutine pass_read @ %def pass_read @ Auxiliary: Read real, integer, string value. We search for an equals sign, the value must follow. <>= subroutine read_rval (u, rval) integer, intent(in) :: u real(default), intent(out) :: rval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) rval end subroutine read_rval subroutine read_ival (u, ival) integer, intent(in) :: u integer, intent(out) :: ival character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) ival end subroutine read_ival subroutine read_sval (u, sval) integer, intent(in) :: u character(*), intent(out) :: sval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) sval end subroutine read_sval subroutine read_lval (u, lval) integer, intent(in) :: u logical, intent(out) :: lval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) lval end subroutine read_lval @ %def read_rval read_ival read_sval read_lval @ Configure. We adjust the number of [[n_calls]], if it is lower than [[n_calls_min_per_channel]] times [[b_channel]], and print a warning message. <>= procedure :: configure => pass_configure <>= subroutine pass_configure (pass, n_it, n_calls, n_calls_min) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_it integer, intent(in) :: n_calls integer, intent(in) :: n_calls_min pass%n_it = n_it pass%n_calls = max (n_calls, n_calls_min) if (pass%n_calls /= n_calls) then write (msg_buffer, "(A,I0)") "VAMP2: too few calls, resetting " & // "n_calls to ", pass%n_calls call msg_warning () end if allocate (pass%calls (n_it), source = 0) allocate (pass%calls_valid (n_it), source = 0) allocate (pass%integral (n_it), source = 0._default) allocate (pass%error (n_it), source = 0._default) allocate (pass%efficiency (n_it), source = 0._default) end subroutine pass_configure @ %def pass_configure @ Given two pass objects, compare them. All parameters must match. Where integrations are done in both (number of calls nonzero), the results must be equal (up to numerical noise). The allocated array sizes might be different, but should match up to the common [[n_it]] value. <>= interface operator (.matches.) module procedure pass_matches end interface operator (.matches.) <>= function pass_matches (pass, ref) result (ok) type(pass_t), intent(in) :: pass, ref integer :: n logical :: ok ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_it == ref%n_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) ok = pass%integral_defined .eqv. ref%integral_defined if (pass%integral_defined) then n = pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid(:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) end if end function pass_matches @ %def pass_matches @ Update a pass object, given a reference. The parameters must match, except for the [[n_it]] entry. The number of complete iterations must be less or equal to the reference, and the number of complete iterations in the reference must be no larger than [[n_it]]. Where results are present in both passes, they must match. Where results are present in the reference only, the pass is updated accordingly. <>= procedure :: update => pass_update <>= subroutine pass_update (pass, ref, ok) class(pass_t), intent(inout) :: pass type(pass_t), intent(in) :: ref logical, intent(out) :: ok integer :: n, n_ref ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) then if (ref%integral_defined) then if (.not. allocated (pass%calls)) then allocate (pass%calls (pass%n_it), source = 0) allocate (pass%calls_valid (pass%n_it), source = 0) allocate (pass%integral (pass%n_it), source = 0._default) allocate (pass%error (pass%n_it), source = 0._default) allocate (pass%efficiency (pass%n_it), source = 0._default) end if n = count (pass%calls /= 0) n_ref = count (ref%calls /= 0) ok = n <= n_ref .and. n_ref <= pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid(:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) if (ok) then pass%calls(n+1:n_ref) = ref%calls(n+1:n_ref) pass%calls_valid(n+1:n_ref) = ref%calls_valid(n+1:n_ref) pass%integral(n+1:n_ref) = ref%integral(n+1:n_ref) pass%error(n+1:n_ref) = ref%error(n+1:n_ref) pass%efficiency(n+1:n_ref) = ref%efficiency(n+1:n_ref) pass%integral_defined = any (pass%calls /= 0) end if end if end if end subroutine pass_update @ %def pass_update @ Match two real numbers: they are equal up to a tolerance, which is $10^{-8}$, matching the number of digits that are output by [[pass_write]]. In particular, if one number is exactly zero, the other one must also be zero. <>= interface operator (.matches.) module procedure real_matches end interface operator (.matches.) <>= elemental function real_matches (x, y) result (ok) real(default), intent(in) :: x, y logical :: ok real(default), parameter :: tolerance = 1.e-8_default ok = abs (x - y) <= tolerance * max (abs (x), abs (y)) end function real_matches @ %def real_matches @ Return the index of the most recent complete integration. If there is none, return zero. <>= procedure :: get_integration_index => pass_get_integration_index <>= function pass_get_integration_index (pass) result (n) class (pass_t), intent(in) :: pass integer :: n integer :: i n = 0 if (allocated (pass%calls)) then do i = 1, pass%n_it if (pass%calls(i) == 0) exit n = i end do end if end function pass_get_integration_index @ %def pass_get_integration_index @ Return the most recent integral and error, if available. <>= procedure :: get_calls => pass_get_calls procedure :: get_calls_valid => pass_get_calls_valid procedure :: get_integral => pass_get_integral procedure :: get_error => pass_get_error procedure :: get_efficiency => pass_get_efficiency <>= function pass_get_calls (pass) result (calls) class(pass_t), intent(in) :: pass integer :: calls integer :: n n = pass%get_integration_index () calls = 0 if (n /= 0) then calls = pass%calls(n) end if end function pass_get_calls function pass_get_calls_valid (pass) result (valid) class(pass_t), intent(in) :: pass integer :: valid integer :: n n = pass%get_integration_index () valid = 0 if (n /= 0) then valid = pass%calls_valid(n) end if end function pass_get_calls_valid function pass_get_integral (pass) result (integral) class(pass_t), intent(in) :: pass real(default) :: integral integer :: n n = pass%get_integration_index () integral = 0 if (n /= 0) then integral = pass%integral(n) end if end function pass_get_integral function pass_get_error (pass) result (error) class(pass_t), intent(in) :: pass real(default) :: error integer :: n n = pass%get_integration_index () error = 0 if (n /= 0) then error = pass%error(n) end if end function pass_get_error function pass_get_efficiency (pass) result (efficiency) class(pass_t), intent(in) :: pass real(default) :: efficiency integer :: n n = pass%get_integration_index () efficiency = 0 if (n /= 0) then efficiency = pass%efficiency(n) end if end function pass_get_efficiency @ %def pass_get_calls @ %def pass_get_calls_valid @ %def pass_get_integral @ %def pass_get_error @ %def pass_get_efficiency @ \subsection{Integrator} \label{sec:integrator} We store the different passes of integration, adaptation and actual sampling, in a linked list. We store the total number of calls [[n_calls]] and the minimal number of calls [[n_calls_min]]. The latter is calculated based on [[n_channel]] and [[min_calls_per_channel]]. If [[n_calls]] is smaller than [[n_calls_min]], then we replace [[n_calls]] with [[n_min_calls]]. <>= public :: mci_vamp2_t <>= type, extends(mci_t) :: mci_vamp2_t type(mci_vamp2_config_t) :: config type(vamp2_t) :: integrator type(vamp2_equivalences_t) :: equivalences logical :: integrator_defined = .false. logical :: integrator_from_file = .false. logical :: adapt_grids = .false. logical :: adapt_weights = .false. integer :: n_adapt_grids = 0 integer :: n_adapt_weights = 0 integer :: n_calls = 0 type(list_pass_t) :: list_pass logical :: rebuild = .true. logical :: check_grid_file = .true. logical :: grid_filename_set = .false. logical :: negative_weights = .false. logical :: verbose = .false. logical :: pass_complete = .false. logical :: it_complete = .false. type(string_t) :: grid_filename integer :: grid_checkpoint = 1 logical :: binary_grid_format = .false. type(string_t) :: parallel_method character(32) :: md5sum_adapted = "" contains <> end type mci_vamp2_t @ %def mci_vamp2_t @ Finalizer: call to base and list finalizer. <>= procedure, public :: final => mci_vamp2_final <>= subroutine mci_vamp2_final (object) class(mci_vamp2_t), intent(inout) :: object call object%list_pass%final () call object%base_final () end subroutine mci_vamp2_final @ %def mci_vamp2_final @ Output. Do not output the grids themselves, this may result in tons of data. <>= procedure, public :: write => mci_vamp2_write <>= subroutine mci_vamp2_write (object, unit, pacify, md5sum_version) class(mci_vamp2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u, i u = given_output_unit (unit) write (u, "(1X,A)") "VAMP2 integrator:" call object%base_write (u, pacify, md5sum_version) write (u, "(1X,A)") "Grid config:" call object%config%write (u) write (u, "(3X,A,L1)") "Integrator defined = ", object%integrator_defined write (u, "(3X,A,L1)") "Integrator from file = ", object%integrator_from_file write (u, "(3X,A,L1)") "Adapt grids = ", object%adapt_grids write (u, "(3X,A,L1)") "Adapt weights = ", object%adapt_weights write (u, "(3X,A,I0)") "No. of adapt grids = ", object%n_adapt_grids write (u, "(3X,A,I0)") "No. of adapt weights = ", object%n_adapt_weights write (u, "(3X,A,L1)") "Verbose = ", object%verbose if (object%config%equivalences) then call object%equivalences%write (u) end if call object%list_pass%write (u, pacify) if (object%md5sum_adapted /= "") then write (u, "(1X,A,A,A)") "MD5 sum (including results) = '", & & object%md5sum_adapted, "'" end if end subroutine mci_vamp2_write @ %def mci_vamp2_write @ Compute the (adapted) MD5 sum, including the configuration MD5 sum and the printout, which incorporates the current results. <>= procedure, public :: compute_md5sum => mci_vamp2_compute_md5sum <>= subroutine mci_vamp2_compute_md5sum (mci, pacify) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in), optional :: pacify integer :: u mci%md5sum_adapted = "" u = free_unit () open (u, status = "scratch", action = "readwrite") write (u, "(A)") mci%md5sum call mci%write (u, pacify, md5sum_version = .true.) rewind (u) mci%md5sum_adapted = md5sum (u) close (u) end subroutine mci_vamp2_compute_md5sum @ %def mci_vamp2_compute_md5sum @ Return the MD5 sum: If available, return the adapted one. <>= procedure, public :: get_md5sum => mci_vamp2_get_md5sum <>= pure function mci_vamp2_get_md5sum (mci) result (md5sum) class(mci_vamp2_t), intent(in) :: mci character(32) :: md5sum if (mci%md5sum_adapted /= "") then md5sum = mci%md5sum_adapted else md5sum = mci%md5sum end if end function mci_vamp2_get_md5sum @ %def mci_vamp_get_md5sum @ Startup message: short version. Make a call to the base function and print additional information about the multi-channel parameters. <>= procedure, public :: startup_message => mci_vamp2_startup_message <>= subroutine mci_vamp2_startup_message (mci, unit, n_calls) class(mci_vamp2_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls integer :: num_calls, n_bins num_calls = 0; if (present (n_calls)) num_calls = n_calls n_bins = mci%config%n_bins_max call mci%base_startup_message (unit = unit, n_calls = n_calls) if (mci%config%equivalences) then write (msg_buffer, "(A)") & "Integrator: Using VAMP2 channel equivalences" call msg_message (unit = unit) end if if (mci%binary_grid_format) then write (msg_buffer, "(A,A,A,A)") & "Integrator: Write grid header to '" // char (mci%get_grid_filename ()) // & "' and grids to '" // char (mci%get_grid_filename (binary_grid_format = .true.)) // "'" else write (msg_buffer, "(A,A,A)") & "Integrator: Write grid header and grids to '" // char (mci%get_grid_filename ()) // "'" end if call msg_message (unit = unit) select case (mci%grid_checkpoint) case (0) write (msg_buffer, "(A)") & "Integrator: Grid checkpoint after each pass" case (1) write (msg_buffer, "(A)") & "Integrator: Grid checkpoint after each iteration" case (2:) write (msg_buffer, "(A,1X,I0,1X,A)") & "Integrator: Grid checkpoint after", mci%grid_checkpoint, & "iterations and after each pass" case default call msg_bug ("Integrator: Cannot assign grid checkpoint (value is negative).") end select call msg_message (unit = unit) write (msg_buffer, "(A,2(1x,I0,1x,A),L1)") & "Integrator:", num_calls, & "initial calls,", n_bins, & "max. bins, stratified = ", & mci%config%stratified call msg_message (unit = unit) write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: VAMP2" call msg_message (unit = unit) end subroutine mci_vamp2_startup_message @ %def mci_vamp2_startup_message @ Log entry: just headline. <>= procedure, public :: write_log_entry => mci_vamp2_write_log_entry <>= subroutine mci_vamp2_write_log_entry (mci, u) class(mci_vamp2_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is VAMP2" call write_separator (u) if (mci%config%equivalences) then call mci%equivalences%write (u) else write (u, "(3x,A)") "No channel equivalences have been used." end if call write_separator (u) call mci%write_chain_weights (u) end subroutine mci_vamp2_write_log_entry @ %def mci_vamp2_write_log_entry @ Set the MCI index (necessary for processes with multiple components). We append the index to the grid filename, just before the final dotted suffix. <>= procedure, public :: record_index => mci_vamp2_record_index <>= subroutine mci_vamp2_record_index (mci, i_mci) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: i_mci type(string_t) :: basename, suffix character(32) :: buffer if (mci%grid_filename_set) then write (buffer, "(I0)") i_mci mci%grid_filename = mci%grid_filename // ".m" // trim (buffer) end if end subroutine mci_vamp2_record_index @ %def mci_vamp2_record_index @ Set the configuration object. We adjust the maximum number of bins [[n_bins_max]] according to [[n_calls]] <>= procedure, public :: set_config => mci_vamp2_set_config <>= subroutine mci_vamp2_set_config (mci, config) class(mci_vamp2_t), intent(inout) :: mci type(mci_vamp2_config_t), intent(in) :: config mci%config = config end subroutine mci_vamp2_set_config @ %def mci_vamp2_set_config @ Set the the rebuild flag, also the for checking the grid. <>= procedure, public :: set_rebuild_flag => mci_vamp2_set_rebuild_flag <>= subroutine mci_vamp2_set_rebuild_flag (mci, rebuild, check_grid_file) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in) :: rebuild logical, intent(in) :: check_grid_file mci%rebuild = rebuild mci%check_grid_file = check_grid_file end subroutine mci_vamp2_set_rebuild_flag @ %def mci_vegaa_set_rebuild_flag @ Set the filename. <>= procedure, public :: set_grid_filename => mci_vamp2_set_grid_filename procedure, public :: get_grid_filename => mci_vamp2_get_grid_filename <>= subroutine mci_vamp2_set_grid_filename (mci, name, run_id) class(mci_vamp2_t), intent(inout) :: mci type(string_t), intent(in) :: name type(string_t), intent(in), optional :: run_id mci%grid_filename = name if (present (run_id)) then mci%grid_filename = name // "." // run_id end if mci%grid_filename_set = .true. end subroutine mci_vamp2_set_grid_filename type(string_t) function mci_vamp2_get_grid_filename (mci, binary_grid_format) & result (filename) class(mci_vamp2_t), intent(in) :: mci logical, intent(in), optional :: binary_grid_format filename = mci%grid_filename // ".vg2" if (present (binary_grid_format)) then if (binary_grid_format) then filename = mci%grid_filename // ".vgx2" end if end if end function mci_vamp2_get_grid_filename @ %def mci_vamp2_set_grid_filename, mci_vamp2_get_grid_filename @ To simplify the interface, we prepend a grid path in a separate subroutine. <>= procedure :: prepend_grid_path => mci_vamp2_prepend_grid_path <>= subroutine mci_vamp2_prepend_grid_path (mci, prefix) class(mci_vamp2_t), intent(inout) :: mci type(string_t), intent(in) :: prefix if (.not. mci%grid_filename_set) then call msg_warning ("VAMP2: Cannot add prefix to invalid integrator filename!") end if mci%grid_filename = prefix // "/" // mci%grid_filename end subroutine mci_vamp2_prepend_grid_path @ %def mci_vamp2_prepend_grid_path @ Not implemented. <>= procedure, public :: declare_flat_dimensions => mci_vamp2_declare_flat_dimensions <>= subroutine mci_vamp2_declare_flat_dimensions (mci, dim_flat) class(mci_vamp2_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_vamp2_declare_flat_dimensions @ %def mci_vamp2_declare_flat_dimensions @ <>= procedure, public :: declare_equivalences => mci_vamp2_declare_equivalences <>= subroutine mci_vamp2_declare_equivalences (mci, channel, dim_offset) class(mci_vamp2_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset integer, dimension(:), allocatable :: perm, mode integer :: n_channels, n_dim, n_equivalences integer :: c, i, j, dest, src integer :: n_dim_perm n_channels = mci%n_channel n_dim = mci%n_dim n_equivalences = 0 do c = 1, n_channels n_equivalences = n_equivalences + size (channel(c)%eq) end do mci%equivalences = vamp2_equivalences_t (& n_eqv = n_equivalences, n_channel = n_channels, n_dim = n_dim) allocate (perm (n_dim)) allocate (mode (n_dim)) perm = [(i, i = 1, n_dim)] mode = 0 c = 1 j = 0 do i = 1, n_equivalences if (j < size (channel(c)%eq)) then j = j + 1 else c = c + 1 j = 1 end if associate (eq => channel(c)%eq(j)) dest = c src = eq%c n_dim_perm = size (eq%perm) perm(dim_offset+1:dim_offset+n_dim_perm) = eq%perm + dim_offset mode(dim_offset+1:dim_offset+n_dim_perm) = eq%mode call mci%equivalences%set_equivalence & (i, dest, src, perm, mode) end associate end do call mci%equivalences%freeze () end subroutine mci_vamp2_declare_equivalences @ %def mci_vamp2_declare_quivalences @ Allocate instance with matching type. <>= procedure, public :: allocate_instance => mci_vamp2_allocate_instance <>= subroutine mci_vamp2_allocate_instance (mci, mci_instance) class(mci_vamp2_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_vamp2_instance_t :: mci_instance) end subroutine mci_vamp2_allocate_instance @ %def mci_vamp2_allocate_instance @ Allocate a new integration pass. We can preset everything that does not depend on the number of iterations and calls. This is postponed to the integrate method. In the final pass, we do not check accuracy goal etc., since we can assume that the user wants to perform and average all iterations in this pass. <>= procedure, public :: add_pass => mci_vamp2_add_pass <>= subroutine mci_vamp2_add_pass (mci, adapt_grids, adapt_weights, final_pass) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass call mci%list_pass%add (adapt_grids, adapt_weights, final_pass) end subroutine mci_vamp2_add_pass @ %def mci_vamp2_add_pass @ Update the list of integration passes. <>= procedure, public :: update_from_ref => mci_vamp2_update_from_ref <>= subroutine mci_vamp2_update_from_ref (mci, mci_ref, success) class(mci_vamp2_t), intent(inout) :: mci class(mci_t), intent(in) :: mci_ref logical, intent(out) :: success select type (mci_ref) type is (mci_vamp2_t) call mci%list_pass%update_from_ref (mci_ref%list_pass, success) if (mci%list_pass%has_last_integral()) then call mci%list_pass%get_last_integral( & integral = mci%integral, & error = mci%error, & efficiency = mci%efficiency) mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. end if end select end subroutine mci_vamp2_update_from_ref @ %def mci_vamp2_update_from_ref @ Update the MCI record (i.e., the integration passes) by reading from input stream. The stream should contain a write output from a previous run. We first check the MD5 sum of the configuration parameters. If that matches, we proceed directly to the stored integration passes. If successful, we may continue to read the file; the position will be after a blank line that must follow the MCI record. <>= procedure, public :: update => mci_vamp2_update <>= subroutine mci_vamp2_update (mci, u, success) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: u logical, intent(out) :: success character(80) :: buffer character(32) :: md5sum_file type(mci_vamp2_t) :: mci_file integer :: n_pass, n_it call read_sval (u, md5sum_file) success = .true.; if (mci%check_grid_file) & & success = (md5sum_file == mci%md5sum) if (success) then read (u, *) read (u, "(A)") buffer if (trim (adjustl (buffer)) /= "VAMP2 integrator:") then call msg_fatal ("VAMP2: reading grid file: corrupted data") end if n_pass = 0 n_it = 0 do read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("") exit case ("Integration pass:") call mci_file%list_pass%add () call mci_file%list_pass%current%read (u, n_pass, n_it) n_pass = n_pass + 1 n_it = n_it + mci_file%list_pass%current%n_it end select end do call mci%update_from_ref (mci_file, success) call mci_file%final () end if end subroutine mci_vamp2_update @ %def mci_vamp2_update @ Read / write grids from / to file. We split the reading process in two parts. First, we check on the header where we check (and update) all relevant pass data using [[mci_vamp2_update]]. In the second part we only read the integrator data. We implement [[mci_vamp2_read]] for completeness. The writing of the MCI object is split into two parts, a header with the relevant process configuration regarding the integration and the results of the different passes and their iterations. The other part is the actual grid. The header will always be written in ASCII format, including a md5 hash, in order to testify against unwilling changes to the setup. The grid part can be either added to the ASCII file, or to an additional binary file. <>= procedure :: write_grids => mci_vamp2_write_grids procedure :: read_header => mci_vamp2_read_header procedure :: read_data => mci_vamp2_read_data procedure, private :: advance_to_data => mci_vamp2_advance_to_data <>= subroutine mci_vamp2_write_grids (mci) class(mci_vamp2_t), intent(in) :: mci integer :: u if (.not. mci%grid_filename_set) then call msg_bug ("VAMP2: write grids: filename undefined") end if if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: write grids: grids undefined") end if open (newunit = u, file = char (mci%get_grid_filename ()), & action = "write", status = "replace") write (u, "(1X,A,A,A)") "MD5sum = '", mci%md5sum, "'" write (u, *) call mci%write (u) write (u, *) if (mci%binary_grid_format) then write (u, "(1X,2A)") "VAMP2 grids: binary file: ", & char (mci%get_grid_filename (binary_grid_format = .true.)) close (u) open (newunit = u, & file = char (mci%get_grid_filename (binary_grid_format = .true.)), & action = "write", & access = "stream", & form = "unformatted", & status = "replace") call mci%integrator%write_binary_grids (u) else write (u, "(1X,A)") "VAMP2 grids:" call mci%integrator%write_grids (u) end if close (u) end subroutine mci_vamp2_write_grids subroutine mci_vamp2_read_header (mci, success) class(mci_vamp2_t), intent(inout) :: mci logical, intent(out) :: success logical :: exist, binary_grid_format, exist_binary integer :: u success = .false. if (.not. mci%grid_filename_set) then call msg_bug ("VAMP2: read grids: filename undefined") end if !! First, check for existence of the (usual) grid file. inquire (file = char (mci%get_grid_filename ()), exist = exist) if (.not. exist) return !! success = .false. open (newunit = u, file = char (mci%get_grid_filename ()), & action = "read", status = "old") !! Second, check for existence of a (possible) binary grid file. call mci%advance_to_data (u, binary_grid_format) rewind (u) !! Rewind header file, after line search. if (binary_grid_format) then inquire (file = char (mci%get_grid_filename (binary_grid_format = .true.)), & exist = exist) if (.not. exist) then write (msg_buffer, "(3A)") & "VAMP2: header: binary grid file not found, discarding grid file '", & char (mci%get_grid_filename ()), "'." call msg_message () return !! success = .false. end if end if !! The grid file (ending *.vg) exists and, if binary file is listed, it exists, too. call mci%update (u, success) close (u) if (.not. success) then write (msg_buffer, "(A,A,A)") & "VAMP2: header: parameter mismatch, discarding pass from file '", & char (mci%get_grid_filename ()), "'." call msg_message () end if end subroutine mci_vamp2_read_header subroutine mci_vamp2_read_data (mci) class(mci_vamp2_t), intent(inout) :: mci integer :: u logical :: binary_grid_format if (mci%integrator_defined) then call msg_bug ("VAMP2: read grids: grids already defined") end if open (newunit = u, & file = char (mci%get_grid_filename ()), & action = "read", & status = "old") call mci%advance_to_data (u, binary_grid_format) if (binary_grid_format) then close (u) write (msg_buffer, "(3A)") & "VAMP2: Reading from binary grid file '", & char (mci%get_grid_filename (binary_grid_format = .true.)), "'" call msg_message () open (newunit = u, & file = char (mci%get_grid_filename (binary_grid_format = .true.)), & action = "read", & access = "stream", & form = "unformatted", & status = "old") call mci%integrator%read_binary_grids (u) else call mci%integrator%read_grids (u) end if mci%integrator_defined = .true. close (u) end subroutine mci_vamp2_read_data subroutine mci_vamp2_advance_to_data (mci, u, binary_grid_format) class(mci_vamp2_t), intent(in) :: mci integer, intent(in) :: u logical, intent(out) :: binary_grid_format character(80) :: buffer type(string_t) :: search_string_binary, search_string_ascii search_string_binary = "VAMP2 grids: binary file: " // & mci%get_grid_filename (binary_grid_format = .true.) search_string_ascii = "VAMP2 grids:" SEARCH: do read (u, "(A)") buffer if (trim (adjustl (buffer)) == char (search_string_binary)) then binary_grid_format = .true. exit SEARCH else if (trim (adjustl (buffer)) == char (search_string_ascii)) then binary_grid_format = .false. exit SEARCH end if end do SEARCH end subroutine mci_vamp2_advance_to_data @ %def mci_vamp2_write_grids @ %def mci_vamp2_read_header @ %def mci_vamp2_read_data @ \subsubsection{Interface: VAMP2} \label{sec:interface-vamp2} We define the interfacing procedures, as such, initialising the VAMP2 integrator or resetting the results. Initialise the VAMP2 integrator which is stored within the [[mci]] object, using the data of the current integration pass. Furthermore, reset the counters that track this set of integrator. <>= procedure, public :: init_integrator => mci_vamp2_init_integrator <>= subroutine mci_vamp2_init_integrator (mci) class(mci_vamp2_t), intent(inout) :: mci type (pass_t), pointer :: current integer :: ch, vegas_mode current => mci%list_pass%current vegas_mode = merge (VEGAS_MODE_IMPORTANCE, VEGAS_MODE_IMPORTANCE_ONLY,& & mci%config%stratified) mci%n_adapt_grids = 0 mci%n_adapt_weights = 0 if (mci%integrator_defined) then call msg_bug ("VAMP2: init integrator: & & integrator is already initialised.") end if mci%integrator = vamp2_t (mci%n_channel, mci%n_dim, & & n_bins_max = mci%config%n_bins_max, & & iterations = 1, & & mode = vegas_mode) if (mci%has_chains ()) call mci%integrator%set_chain (mci%n_chain, mci%chain) call mci%integrator%set_config (mci%config) mci%integrator_defined = .true. end subroutine mci_vamp2_init_integrator @ %def mci_vamp2_init_integrator @ Reset a grid set. Purge the accumulated results. <>= procedure, public :: reset_result => mci_vamp2_reset_result <>= subroutine mci_vamp2_reset_result (mci) class(mci_vamp2_t), intent(inout) :: mci if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: reset results: integrator undefined") end if call mci%integrator%reset_result () end subroutine mci_vamp2_reset_result @ %def mci_vamp2_reset_result @ Set calls per channel. The number of calls to each channel is defined by the channel weight \begin{equation} \alpha_i = \frac{N_i}{\sum N_i}. \end{equation} <>= procedure, public :: set_calls => mci_vamp2_set_calls <>= subroutine mci_vamp2_set_calls (mci, n_calls) class(mci_vamp2_t), intent(inout) :: mci integer :: n_calls if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: set calls: grids undefined") end if call mci%integrator%set_calls (n_calls) end subroutine mci_vamp2_set_calls @ %def mci_vamp2_set_calls \subsubsection{Integration} Initialize. We prepare the integrator from a previous pass, or from file, or with new objects. At the end, we update the number of calls either when we got the integration grids from file and we added new iterations to the current pass, or we allocated a new integrator. <>= procedure, private :: init_integration => mci_vamp2_init_integration <>= subroutine mci_vamp2_init_integration (mci, n_it, n_calls, instance) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_instance_t), intent(inout) :: instance logical :: from_file, success if (.not. associated (mci%list_pass%current)) then call msg_bug ("MCI integrate: current_pass object not allocated") end if associate (current_pass => mci%list_pass%current) current_pass%integral_defined = .false. mci%config%n_calls_min = mci%config%n_calls_min_per_channel * mci%config%n_channel call current_pass%configure (n_it, n_calls, mci%config%n_calls_min) mci%adapt_grids = current_pass%adapt_grids mci%adapt_weights = current_pass%adapt_weights mci%pass_complete = .false. mci%it_complete = .false. from_file = .false. if (.not. mci%integrator_defined .or. mci%integrator_from_file) then if (mci%grid_filename_set .and. .not. mci%rebuild) then call mci%read_header (success) from_file = success if (.not. mci%integrator_defined .and. success) & call mci%read_data () end if end if if (from_file) then if (.not. mci%check_grid_file) & & call msg_warning ("Reading grid file: MD5 sum check disabled") call msg_message ("VAMP2: " & // "Using grids and results from file ’" & // char (mci%get_grid_filename ()) // "’.") else if (.not. mci%integrator_defined) then call msg_message ("VAMP2: " & // "Initialize new grids and write to file '" & // char (mci%get_grid_filename ()) // "'.") call mci%init_integrator () end if mci%integrator_from_file = from_file if (.not. mci%integrator_from_file .or. (n_it > current_pass%get_integration_index ())) then call mci%integrator%set_calls (current_pass%n_calls) end if call mci%integrator%set_equivalences (mci%equivalences) end associate <> end subroutine mci_vamp2_init_integration @ %def mci_vamp2_init @ Allocate request object and load into integrator object. <>= if (mci%parallel_method /= "") then call mci%integrator%allocate_request (method = char (mci%parallel_method)) else call msg_message ("VAMP2: Use default parallel method: simple.") call mci%integrator%allocate_request (method = "simple") end if @ Integrate. Perform a new integration pass (possibly reusing previous results), which may consist of several iterations. We reinitialise the sampling new each time and set the workspace again. Note: we record the integral once per iteration. The integral stored in the mci record itself is the last integral of the current iteration, no averaging done. The results record may average results. Note: recording the efficiency is not supported yet. <>= procedure, public :: integrate => mci_vamp2_integrate <>= subroutine mci_vamp2_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_results_t), intent(inout), optional :: results logical, intent(in), optional :: pacify integer :: it logical :: from_file, success <> <> call mci%init_integration (n_it, n_calls, instance) from_file = mci%integrator_from_file select type (instance) type is (mci_vamp2_instance_t) call instance%set_workspace (sampler) end select associate (current_pass => mci%list_pass%current) do it = 1, current_pass%n_it if (signal_is_pending ()) return mci%integrator_from_file = from_file .and. & it <= current_pass%get_integration_index () if (.not. mci%integrator_from_file) then mci%it_complete = .false. select type (instance) type is (mci_vamp2_instance_t) call mci%integrator%integrate (instance%func, mci%rng, & & iterations = 1, & & reset_result = .true., & & refine_grids = mci%adapt_grids, & & adapt_weights = mci%adapt_weights, & & verbose = mci%verbose) end select if (signal_is_pending ()) return mci%it_complete = .true. integral = mci%integrator%get_integral () calls = mci%integrator%get_n_calls () select type (instance) type is (mci_vamp2_instance_t) calls_valid = instance%func%get_n_calls () call instance%func%reset_n_calls () end select error = sqrt (mci%integrator%get_variance ()) efficiency = mci%integrator%get_efficiency () <> if (integral /= 0) then current_pass%integral(it) = integral current_pass%calls(it) = calls current_pass%calls_valid(it) = calls_valid current_pass%error(it) = error current_pass%efficiency(it) = efficiency end if current_pass%integral_defined = .true. end if if (present (results)) then if (mci%has_chains ()) then call mci%collect_chain_weights (instance%w) call results%record (1, & n_calls = current_pass%calls(it), & n_calls_valid = current_pass%calls_valid(it), & integral = current_pass%integral(it), & error = current_pass%error(it), & efficiency = current_pass%efficiency(it), & efficiency_pos = current_pass%efficiency(it), & efficiency_neg = 0._default, & chain_weights = mci%chain_weights, & suppress = pacify) else call results%record (1, & n_calls = current_pass%calls(it), & n_calls_valid = current_pass%calls_valid(it), & integral = current_pass%integral(it), & error = current_pass%error(it), & efficiency = current_pass%efficiency(it), & efficiency_pos = current_pass%efficiency(it), & efficiency_neg = 0._default, & suppress = pacify) end if end if if (.not. mci%integrator_from_file & .and. mci%grid_filename_set) then <> call checkpoint_and_write_grids (it = it, & final_it = (it == current_pass%n_it)) end if if (.not. current_pass%is_final_pass) then call check_goals (it, success) if (success) exit end if end do if (signal_is_pending ()) return mci%pass_complete = .true. mci%integral = current_pass%get_integral() mci%error = current_pass%get_error() mci%efficiency = current_pass%get_efficiency() mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. call mci%compute_md5sum (pacify) end associate contains <> end subroutine mci_vamp2_integrate @ %def mci_vamp2_integrate <>= real(default) :: integral, error, efficiency integer :: calls, calls_valid @ <>= @ <>= @ <>= @ <>= integer :: rank, n_size type(MPI_Request), dimension(6) :: request @ MPI procedure-specific initialization. <>= call MPI_Comm_size (MPI_COMM_WORLD, n_size) call MPI_Comm_rank (MPI_COMM_WORLD, rank) @ We broadcast the current results to all worker, such that they can store them in to the pass list. <>= call MPI_Ibcast (integral, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, request(1)) call MPI_Ibcast (calls, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, request(2)) call MPI_Ibcast (calls_valid, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, request(3)) call MPI_Ibcast (error, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, request(4)) call MPI_Ibcast (efficiency, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, request(5)) call MPI_Waitall (5, request, MPI_STATUSES_IGNORE) @ We only allow the master to write the grids to file. <>= if (rank == 0) & @ Write grids to [[grid_filename]] at a given checkpoint. We qualify each iteration and pass as possible checkpoint. However, we allow the user to alter the checkpoint behavior: \begin{itemize} \item after every iteration, \item after every pass, \item after a \(N\) iterations and every pass. \end{itemize} The user sets the Sindarin variable [[vamp_grid_checkpoint]] to an integer value where the value 0 represents each pass, value 1 each iteration, and a value \(> 1\) means after \(N\) iterations (or at the last iteration of a pass). <>= subroutine checkpoint_and_write_grids (it, final_it) integer, intent(in) :: it logical, intent(in) :: final_it select case (mci%grid_checkpoint) case (0) if (.not. final_it) return case (1) case(2:) if (.not. (final_it & .or. mod (it, mci%grid_checkpoint) == 0)) return case default call msg_bug ("VAMP2: Grid checkpoint must be a positive integer.") end select call mci%write_grids () end subroutine checkpoint_and_write_grids @ Check whether we are already finished with this pass. <>= subroutine check_goals (it, success) integer, intent(in) :: it logical, intent(out) :: success success = .false. associate (current_pass => mci%list_pass%current) if (error_reached (it)) then current_pass%n_it = it call msg_message ("VAMP2: error goal reached; & &skipping iterations") success = .true. return end if if (rel_error_reached (it)) then current_pass%n_it = it call msg_message ("VAMP2: relative error goal reached; & &skipping iterations") success = .true. return end if if (accuracy_reached (it)) then current_pass%n_it = it call msg_message ("VAMP2: accuracy goal reached; & &skipping iterations") success = .true. return end if end associate end subroutine check_goals @ %def mci_vamp2_check_goals @ Return true if the error, relative error or accurary goals hase been reached, if any. <>= function error_reached (it) result (flag) integer, intent(in) :: it logical :: flag real(default) :: error_goal, error error_goal = mci%config%error_goal flag = .false. associate (current_pass => mci%list_pass%current) if (error_goal > 0 .and. current_pass%integral_defined) then error = abs (current_pass%error(it)) flag = error < error_goal end if end associate end function error_reached function rel_error_reached (it) result (flag) integer, intent(in) :: it logical :: flag real(default) :: rel_error_goal, rel_error rel_error_goal = mci%config%rel_error_goal flag = .false. associate (current_pass => mci%list_pass%current) if (rel_error_goal > 0 .and. current_pass%integral_defined) then rel_error = abs (current_pass%error(it) / current_pass%integral(it)) flag = rel_error < rel_error_goal end if end associate end function rel_error_reached function accuracy_reached (it) result (flag) integer, intent(in) :: it logical :: flag real(default) :: accuracy_goal, accuracy accuracy_goal = mci%config%accuracy_goal flag = .false. associate (current_pass => mci%list_pass%current) if (accuracy_goal > 0 .and. current_pass%integral_defined) then if (current_pass%integral(it) /= 0) then accuracy = abs (current_pass%error(it) / current_pass%integral(it)) & * sqrt (real (current_pass%calls(it), default)) flag = accuracy < accuracy_goal else flag = .true. end if end if end associate end function accuracy_reached @ %def error_reached, rel_error_reached, accuracy_reached @ \subsection{Event generation} Prepare simulation. We check the grids and reread them from file, if necessary. <>= procedure, public :: prepare_simulation => mci_vamp2_prepare_simulation <>= subroutine mci_vamp2_prepare_simulation (mci) class(mci_vamp2_t), intent(inout) :: mci logical :: success if (.not. mci%grid_filename_set) then call msg_bug ("VAMP2: preapre simulation: integrator filename not set.") end if call mci%read_header (success) call mci%compute_md5sum () if (.not. success) then call msg_fatal ("Simulate: " & // "reading integration grids from file ’" & // char (mci%get_grid_filename ()) // "’ failed") end if if (.not. mci%integrator_defined) then call mci%read_data () end if call groom_rng (mci%rng) contains subroutine groom_rng (rng) class(rng_t), intent(inout) :: rng integer :: i, rank, n_size call mpi_get_comm_id (n_size, rank) do i = 2, rank + 1 select type (rng) type is (rng_stream_t) call rng%next_substream () if (i == rank) & call msg_message ("MCI: Advance RNG for parallel event simulation") class default call msg_bug ("Use of any random number generator & &beside rng_stream for parallel event generation not supported.") end select end do end subroutine groom_rng end subroutine mci_vamp2_prepare_simulation @ %def mci_vamp2_prepare_simulation @ Generate an unweighted event. We only set the workspace again before generating an event. <>= procedure, public :: generate_weighted_event => mci_vamp2_generate_weighted_event <>= subroutine mci_vamp2_generate_weighted_event (mci, instance, sampler) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: generate weighted event: undefined integrator") end if select type (instance) type is (mci_vamp2_instance_t) instance%event_generated = .false. call instance%set_workspace (sampler) call mci%integrator%generate_weighted (& & instance%func, mci%rng, instance%event_x) instance%event_weight = mci%integrator%get_evt_weight () instance%event_excess = 0 instance%n_events = instance%n_events + 1 instance%event_generated = .true. end select end subroutine mci_vamp2_generate_weighted_event @ %def mci_vamp2_generate_weighted_event @ We apply an additional rescaling factor for [[f_max]] (either for the positive or negative distribution). <>= procedure, public :: generate_unweighted_event => mci_vamp2_generate_unweighted_event <>= subroutine mci_vamp2_generate_unweighted_event (mci, instance, sampler) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: generate unweighted event: undefined integrator") end if select type (instance) type is (mci_vamp2_instance_t) instance%event_generated = .false. call instance%set_workspace (sampler) generate: do call mci%integrator%generate_unweighted (& & instance%func, mci%rng, instance%event_x, & & opt_event_rescale = instance%event_rescale_f_max) instance%event_excess = mci%integrator%get_evt_weight_excess () if (signal_is_pending ()) return if (sampler%is_valid ()) exit generate end do generate if (mci%integrator%get_evt_weight () < 0.) then if (.not. mci%negative_weights) then call msg_fatal ("VAMP2: cannot sample negative weights!") end if instance%event_weight = -1._default else instance%event_weight = 1._default end if instance%n_events = instance%n_events + 1 instance%event_generated = .true. end select end subroutine mci_vamp2_generate_unweighted_event @ %def mci_vamp2_generate_unweighted_event @ <>= procedure, public :: rebuild_event => mci_vamp2_rebuild_event <>= subroutine mci_vamp2_rebuild_event (mci, instance, sampler, state) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state call msg_bug ("VAMP2: rebuild event not implemented yet.") end subroutine mci_vamp2_rebuild_event @ %def mci_vamp2_rebuild_event @ \subsection{Integrator instance} \label{sec:nistance} We store all information relevant for simulation. The event weight is stored, when a weighted event is generated, and the event excess, when a larger weight occurs than actual stored max. weight. We give the possibility to rescale the [[f_max]] within the integrator object with [[event_rescale_f_max]]. <>= public :: mci_vamp2_instance_t <>= type, extends (mci_instance_t) :: mci_vamp2_instance_t class(mci_vamp2_func_t), allocatable :: func real(default), dimension(:), allocatable :: gi integer :: n_events = 0 logical :: event_generated = .false. real(default) :: event_weight = 0. real(default) :: event_excess = 0. real(default) :: event_rescale_f_max = 1. real(default), dimension(:), allocatable :: event_x contains <> end type mci_vamp2_instance_t @ %def mci_vamp2_instance_t @ Output. <>= procedure, public :: write => mci_vamp2_instance_write <>= subroutine mci_vamp2_instance_write (object, unit, pacify) class(mci_vamp2_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u, ch, j character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(1X,A)") "MCI VAMP2 instance:" write (u, "(1X,A,I0)") & & "Selected channel = ", object%selected_channel write (u, "(1X,A25,1X," // fmt // ")") & & "Integrand = ", object%integrand write (u, "(1X,A25,1X," // fmt // ")") & & "MCI weight = ", object%mci_weight write (u, "(1X,A,L1)") & & "Valid = ", object%valid write (u, "(1X,A)") "MCI a-priori weight:" do ch = 1, size (object%w) write (u, "(3X,I25,1X," // fmt // ")") ch, object%w(ch) end do write (u, "(1X,A)") "MCI jacobian:" do ch = 1, size (object%w) write (u, "(3X,I25,1X," // fmt // ")") ch, object%f(ch) end do write (u, "(1X,A)") "MCI mapped x:" do ch = 1, size (object%w) do j = 1, size (object%x, 1) write (u, "(3X,2(1X,I8),1X," // fmt // ")") j, ch, object%x(j, ch) end do end do write (u, "(1X,A)") "MCI channel weight:" do ch = 1, size (object%w) write (u, "(3X,I25,1X," // fmt // ")") ch, object%gi(ch) end do write (u, "(1X,A,I0)") & & "Number of event = ", object%n_events write (u, "(1X,A,L1)") & & "Event generated = ", object%event_generated write (u, "(1X,A25,1X," // fmt // ")") & & "Event weight = ", object%event_weight write (u, "(1X,A25,1X," // fmt // ")") & & "Event excess = ", object%event_excess write (u, "(1X,A25,1X," // fmt // ")") & & "Event rescale f max = ", object%event_rescale_f_max write (u, "(1X,A,L1)") & & "Negative (event) weight = ", object%negative_weights write (u, "(1X,A)") "MCI event" do j = 1, size (object%event_x) write (u, "(3X,I25,1X," // fmt // ")") j, object%event_x(j) end do end subroutine mci_vamp2_instance_write @ %def mci_vamp2_instance_write @ Finalizer. We are only using allocatable, so there is nothing to do here. <>= procedure, public :: final => mci_vamp2_instance_final <>= subroutine mci_vamp2_instance_final (object) class(mci_vamp2_instance_t), intent(inout) :: object ! end subroutine mci_vamp2_instance_final @ %def mci_vamp2_instance_final @ Initializer. <>= procedure, public :: init => mci_vamp2_instance_init <>= subroutine mci_vamp2_instance_init (mci_instance, mci) class(mci_vamp2_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) allocate (mci_instance%gi(mci%n_channel), source=0._default) allocate (mci_instance%event_x(mci%n_dim), source=0._default) allocate (mci_vamp2_func_t :: mci_instance%func) call mci_instance%func%init (n_dim = mci%n_dim, n_channel = mci%n_channel) end subroutine mci_vamp2_instance_init @ %def mci_vamp2_instance_init @ Set workspace for [[mci_vamp2_func_t]]. <>= procedure, public :: set_workspace => mci_vamp2_instance_set_workspace <>= subroutine mci_vamp2_instance_set_workspace (instance, sampler) class(mci_vamp2_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler call instance%func%set_workspace (instance, sampler) end subroutine mci_vamp2_instance_set_workspace @ %def mci_vmp2_instance_set_workspace @ \subsubsection{Evaluation} Compute multi-channel weight. The computation of the multi-channel weight is done by the VAMP2 function. We retrieve the information. <>= procedure, public :: compute_weight => mci_vamp2_instance_compute_weight <>= subroutine mci_vamp2_instance_compute_weight (mci, c) class(mci_vamp2_instance_t), intent(inout) :: mci integer, intent(in) :: c mci%gi = mci%func%get_probabilities () mci%mci_weight = mci%func%get_weight () end subroutine mci_vamp2_instance_compute_weight @ %def mci_vamp2_instance_compute_weight @ Record the integrand. <>= procedure, public :: record_integrand => mci_vamp2_instance_record_integrand <>= subroutine mci_vamp2_instance_record_integrand (mci, integrand) class(mci_vamp2_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand call mci%func%set_integrand (integrand) end subroutine mci_vamp2_instance_record_integrand @ %def mci_vamp2_instance_record_integrand @ \subsubsection{Event simulation} In contrast to VAMP, we reset only counters and set the safety factor, which will then will be applied each time an event is generated. In that way we do not rescale the actual values in the integrator, but more the current value! <>= procedure, public :: init_simulation => mci_vamp2_instance_init_simulation <>= subroutine mci_vamp2_instance_init_simulation (instance, safety_factor) class(mci_vamp2_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor if (present (safety_factor)) instance%event_rescale_f_max = safety_factor instance%n_events = 0 instance%event_generated = .false. if (instance%event_rescale_f_max /= 1) then write (msg_buffer, "(A,ES10.3,A)") "Simulate: & &applying safety factor ", instance%event_rescale_f_max, & & " to event rejection." call msg_message () end if end subroutine mci_vamp2_instance_init_simulation @ %def mci_vamp2_instance_init_simulation @ <>= procedure, public :: final_simulation => mci_vamp2_instance_final_simulation <>= subroutine mci_vamp2_instance_final_simulation (instance) class(mci_vamp2_instance_t), intent(inout) :: instance ! end subroutine mci_vamp2_instance_final_simulation @ %def mci_vamp2_instance_final @ <>= procedure, public :: get_event_weight => mci_vamp2_instance_get_event_weight <>= function mci_vamp2_instance_get_event_weight (mci) result (weight) class(mci_vamp2_instance_t), intent(in) :: mci real(default) :: weight if (.not. mci%event_generated) then call msg_bug ("VAMP2: get event weight: no event generated") end if weight = mci%event_weight end function mci_vamp2_instance_get_event_weight @ %def mci_vamp2_instance_get_event_weight @ <>= procedure, public :: get_event_excess => mci_vamp2_instance_get_event_excess <>= function mci_vamp2_instance_get_event_excess (mci) result (excess) class(mci_vamp2_instance_t), intent(in) :: mci real(default) :: excess if (.not. mci%event_generated) then call msg_bug ("VAMP2: get event excess: no event generated") end if excess = mci%event_excess end function mci_vamp2_instance_get_event_excess @ %def mci_vamp2_instance_get_event_excess @ \clearpage \subsection{Unit tests} \label{sec:mic-vamp2-ut} Test module, followed by the corresponding implementation module. <<[[mci_vamp2_ut.f90]]>>= <> module mci_vamp2_ut use unit_tests use mci_vamp2_uti <> <> contains <> end module mci_vamp2_ut @ %def mci_vamp2_ut @ <<[[mci_vamp2_uti.f90]]>>= <> module mci_vamp2_uti <> <> use io_units use constants, only: PI, TWOPI use rng_base use rng_tao use rng_stream use mci_base use mci_vamp2 <> <> <> contains <> end module mci_vamp2_uti @ %def mci_vamp2_uti @ API: driver for the unit tests below. <>= public :: mci_vamp2_test <>= subroutine mci_vamp2_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_vamp2_test @ %def mci_vamp2_test @ \subsubsection{Test sampler} \label{sec:mci-vamp2-test-sampler} A test sampler object should implement a function with known integral that we can use to check the integrator. In mode [[1]], the function is $f(x) = 3 x^2$ with integral $\int_0^1 f(x)\,dx=1$ and maximum $f(1)=3$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). In mode [[2]], the function is $11 x^{10}$, also with integral $1$. Mode [[4]] includes ranges of zero and negative function value, the integral is negative. The results should be identical to the results of [[mci_midpoint_4]], where the same function is evaluated. The function is $f(x) = (1 - 3 x^2)\,\theta(x-1/2)$ with integral $\int_0^1 f(x)\,dx=-3/8$, minimum $f(1)=-2$ and maximum $f(1/2)=1/4$. <>= type, extends (mci_sampler_t) :: test_sampler_1_t real(default), dimension(:), allocatable :: x real(default) :: val integer :: mode = 1 contains <> end type test_sampler_1_t @ %def test_sampler_1_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure, public :: write => test_sampler_1_write <>= subroutine test_sampler_1_write (object, unit, testflag) class(test_sampler_1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) select case (object%mode) case (1) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2" case (2) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10" case (3) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10 * 2 * cos^2 (2 pi y)" case (4) write (u, "(1x,A)") "Test sampler: f(x) = (1 - 3 x^2) theta(x - 1/2)" end select end subroutine test_sampler_1_write @ %def test_sampler_1_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure, public :: evaluate => test_sampler_1_evaluate <>= subroutine test_sampler_1_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in select case (sampler%mode) case (1) sampler%val = 3 * x_in(1) ** 2 case (2) sampler%val = 11 * x_in(1) ** 10 case (3) sampler%val = 11 * x_in(1) ** 10 * 2 * cos (twopi * x_in(2)) ** 2 case (4) if (x_in(1) >= .5_default) then sampler%val = 1 - 3 * x_in(1) ** 2 else sampler%val = 0 end if end select call sampler%fetch (val, x, f) end subroutine test_sampler_1_evaluate @ %def test_sampler_1_evaluate @ The point is always valid. <>= procedure, public :: is_valid => test_sampler_1_is_valid <>= function test_sampler_1_is_valid (sampler) result (valid) class(test_sampler_1_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_1_is_valid @ %def test_sampler_1_is_valid @ Rebuild: compute all but the function value. <>= procedure, public :: rebuild => test_sampler_1_rebuild <>= subroutine test_sampler_1_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_rebuild @ %def test_sampler_1_rebuild @ Extract the results. <>= procedure, public :: fetch => test_sampler_1_fetch <>= subroutine test_sampler_1_fetch (sampler, val, x, f) class(test_sampler_1_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_fetch @ %def test_sampler_1_fetch @ \subsubsection{Two-channel, two dimension test sampler} This sampler implements the function \begin{equation} f(x, y) = 4\sin^2(\pi x)\sin^2(\pi y) + 2\sin^2(\pi v) \end{equation} where \begin{align} x &= u^v &u &= xy \\ y &= u^{(1-v)} &v &= \frac12\left(1 + \frac{\log(x/y)}{\log xy}\right) \end{align} Each term contributes $1$ to the integral. The first term in the function is peaked along a cross aligned to the coordinates $x$ and $y$, while the second term is peaked along the diagonal $x=y$. The Jacobian is \begin{equation} \frac{\partial(x,y)}{\partial(u,v)} = |\log u| \end{equation} <>= type, extends (mci_sampler_t) :: test_sampler_2_t real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f real(default) :: val contains <> end type test_sampler_2_t @ %def test_sampler_2_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure, public :: write => test_sampler_2_write <>= subroutine test_sampler_2_write (object, unit, testflag) class(test_sampler_2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Two-channel test sampler 2" end subroutine test_sampler_2_write @ %def test_sampler_2_write @ Kinematics: compute $x$ and Jacobians, given the input parameter array. <>= procedure, public :: compute => test_sampler_2_compute <>= subroutine test_sampler_2_compute (sampler, c, x_in) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default) :: xx, yy, uu, vv if (.not. allocated (sampler%x)) & allocate (sampler%x (size (x_in), 2)) if (.not. allocated (sampler%f)) & allocate (sampler%f (2)) select case (c) case (1) xx = x_in(1) yy = x_in(2) uu = xx * yy vv = (1 + log (xx/yy) / log (xx*yy)) / 2 case (2) uu = x_in(1) vv = x_in(2) xx = uu ** vv yy = uu ** (1 - vv) end select sampler%val = (2 * sin (pi * xx) * sin (pi * yy)) ** 2 & + 2 * sin (pi * vv) ** 2 sampler%f(1) = 1 sampler%f(2) = abs (log (uu)) sampler%x(:,1) = [xx, yy] sampler%x(:,2) = [uu, vv] end subroutine test_sampler_2_compute @ %def test_sampler_kinematics @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure, public :: evaluate => test_sampler_2_evaluate <>= subroutine test_sampler_2_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) call sampler%fetch (val, x, f) end subroutine test_sampler_2_evaluate @ %def test_sampler_2_evaluate @ The point is always valid. <>= procedure, public :: is_valid => test_sampler_2_is_valid <>= function test_sampler_2_is_valid (sampler) result (valid) class(test_sampler_2_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_2_is_valid @ %def test_sampler_2_is_valid @ Rebuild: compute all but the function value. <>= procedure, public :: rebuild => test_sampler_2_rebuild <>= subroutine test_sampler_2_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) x = sampler%x f = sampler%f end subroutine test_sampler_2_rebuild @ %def test_sampler_2_rebuild @ Extract the results. <>= procedure, public :: fetch => test_sampler_2_fetch <>= subroutine test_sampler_2_fetch (sampler, val, x, f) class(test_sampler_2_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x = sampler%x f = sampler%f end subroutine test_sampler_2_fetch @ %def test_sampler_2_fetch @ \subsubsection{One-dimensional integration} \label{sec:mci-vamp2-one-dim} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_vamp2_1, "mci_vamp2_1", "one-dimensional integral", u, results) <>= public :: mci_vamp2_1 <>= subroutine mci_vamp2_1 (u) integer, intent(in) :: u type(mci_vamp2_config_t) :: config class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable, target :: mci_sampler class(rng_t), allocatable :: rng type(string_t) :: filename write (u, "(A)") "* Test output: mci_vamp2_1" write (u, "(A)") "* Purpose: integrate function in one dimension (single channel)" write (u, "(A)") write (u, "(A)") "* Initialise integrator" write (u, "(A)") allocate (mci_vamp2_t :: mci) call mci%set_dimensions (1, 1) filename = "mci_vamp2_1" select type (mci) type is (mci_vamp2_t) call mci%set_config (config) call mci%set_grid_filename (filename) end select allocate (rng_stream_t :: rng) call rng%init () call mci%import_rng (rng) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Initialise instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") write (u, "(A)") "* Initialise test sampler" write (u, "(A)") allocate (test_sampler_1_t :: mci_sampler) call mci_sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") " (lower precision to avoid" write (u, "(A)") " numerical noise)" write (u, "(A)") select type (mci) type is (mci_vamp2_t) call mci%add_pass () end select call mci%integrate (mci_instance, mci_sampler, 1, 1000, pacify = .true.) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Dump channel weights and grids to file" write (u, "(A)") mci%md5sum = "1234567890abcdef1234567890abcdef" select type (mci) type is (mci_vamp2_t) call mci%write_grids () end select write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp2_1" end subroutine mci_vamp2_1 @ %def mci_vamp2_test1 @ \subsubsection{Multiple iterations} Construct an integrator and use it for a one-dimensional sampler. Integrate with five iterations without grid adaptation. <>= call test (mci_vamp2_2, "mci_vamp2_2", & "multiple iterations", & u, results) <>= public :: mci_vamp2_2 <>= subroutine mci_vamp2_2 (u) type(mci_vamp2_config_t) :: config integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng type(string_t) :: filename write (u, "(A)") "* Test output: mci_vamp2_2" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel), but multiple iterations." write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp2_t :: mci) call mci%set_dimensions (1, 1) filename = "mci_vamp2_2" select type (mci) type is (mci_vamp2_t) call mci%set_config (config) call mci%set_grid_filename (filename) end select allocate (rng_stream_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp2_t) call mci%add_pass (adapt_grids = .false.) end select call mci%integrate (mci_instance, sampler, 3, 1000, pacify = .true.) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Dump channel weights and grids to file" write (u, "(A)") mci%md5sum = "1234567890abcdef1234567890abcdef" select type (mci) type is (mci_vamp2_t) call mci%write_grids () end select write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp2_2" end subroutine mci_vamp2_2 @ %def mci_vamp2_2 @ \subsubsection{Grid adaptation} Construct an integrator and use it for a one-dimensional sampler. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp2_3, "mci_vamp2_3", & "grid adaptation", & u, results) <>= public :: mci_vamp2_3 <>= subroutine mci_vamp2_3 (u) integer, intent(in) :: u type(mci_vamp2_config_t) :: config class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng type(string_t) :: filename write (u, "(A)") "* Test output: mci_vamp2_3" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp2_t :: mci) call mci%set_dimensions (1, 1) filename = "mci_vamp2_3" select type (mci) type is (mci_vamp2_t) call mci%set_grid_filename (filename) call mci%set_config (config) end select allocate (rng_stream_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp2_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000, pacify = .true.) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Dump channel weights and grids to file" write (u, "(A)") mci%md5sum = "1234567890abcdef1234567890abcdef" select type (mci) type is (mci_vamp2_t) call mci%write_grids () end select write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp2_3" end subroutine mci_vamp2_3 @ %def mci_vamp2_3 @ \section{Dispatch} @ <<[[dispatch_mci.f90]]>>= <> module dispatch_mci <> use diagnostics use os_interface use variables use mci_base use mci_none use mci_midpoint use mci_vamp use mci_vamp2 <> <> <> contains <> end module dispatch_mci @ %def dispatch_mci @ Allocate an integrator according to the variable [[$integration_method]]. <>= public :: dispatch_mci_s <>= subroutine dispatch_mci_s (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo type(string_t) :: run_id type(string_t) :: integration_method type(grid_parameters_t) :: grid_par type(history_parameters_t) :: history_par type(mci_vamp2_config_t) :: mci_vamp2_config integer :: grid_checkpoint logical :: rebuild_grids, check_grid_file, negative_weights, verbose logical :: dispatch_nlo, binary_grid_format type(string_t) :: grid_path, parallel_method dispatch_nlo = .false.; if (present (is_nlo)) dispatch_nlo = is_nlo integration_method = & var_list%get_sval (var_str ("$integration_method")) select case (char (integration_method)) case ("none") allocate (mci_none_t :: mci) case ("midpoint") allocate (mci_midpoint_t :: mci) case ("vamp", "default") call unpack_options_vamp () allocate (mci_vamp_t :: mci) select type (mci) type is (mci_vamp_t) call mci%set_grid_parameters (grid_par) if (run_id /= "") then call mci%set_grid_filename (process_id, run_id) else call mci%set_grid_filename (process_id) end if grid_path = var_list%get_sval (var_str ("$integrate_workspace")) if (grid_path /= "") then call setup_grid_path (grid_path) call mci%prepend_grid_path (grid_path) end if call mci%set_history_parameters (history_par) call mci%set_rebuild_flag (rebuild_grids, check_grid_file) mci%negative_weights = negative_weights mci%verbose = verbose end select case ("vamp2") call unpack_options_vamp2 () allocate (mci_vamp2_t :: mci) select type (mci) type is (mci_vamp2_t) call mci%set_config (mci_vamp2_config) if (run_id /= "") then call mci%set_grid_filename (process_id, run_id) else call mci%set_grid_filename (process_id) end if grid_path = var_list%get_sval (var_str ("$integrate_workspace")) if (grid_path /= "") then call setup_grid_path (grid_path) call mci%prepend_grid_path (grid_path) end if call mci%set_rebuild_flag (rebuild_grids, check_grid_file) mci%negative_weights = negative_weights mci%verbose = verbose mci%grid_checkpoint = grid_checkpoint mci%binary_grid_format = binary_grid_format mci%parallel_method = parallel_method end select case default call msg_fatal ("Integrator '" & // char (integration_method) // "' not implemented") end select contains <> end subroutine dispatch_mci_s @ %def dispatch_mci_s @ <>= subroutine unpack_options_vamp () grid_par%threshold_calls = & var_list%get_ival (var_str ("threshold_calls")) grid_par%min_calls_per_channel = & var_list%get_ival (var_str ("min_calls_per_channel")) grid_par%min_calls_per_bin = & var_list%get_ival (var_str ("min_calls_per_bin")) grid_par%min_bins = & var_list%get_ival (var_str ("min_bins")) grid_par%max_bins = & var_list%get_ival (var_str ("max_bins")) grid_par%stratified = & var_list%get_lval (var_str ("?stratified")) select case (char (var_list%get_sval (var_str ("$phs_method")))) case ("rambo") grid_par%use_vamp_equivalences = .false. case default grid_par%use_vamp_equivalences = & var_list%get_lval (var_str ("?use_vamp_equivalences")) end select grid_par%channel_weights_power = & var_list%get_rval (var_str ("channel_weights_power")) grid_par%accuracy_goal = & var_list%get_rval (var_str ("accuracy_goal")) grid_par%error_goal = & var_list%get_rval (var_str ("error_goal")) grid_par%rel_error_goal = & var_list%get_rval (var_str ("relative_error_goal")) history_par%global = & var_list%get_lval (var_str ("?vamp_history_global")) history_par%global_verbose = & var_list%get_lval (var_str ("?vamp_history_global_verbose")) history_par%channel = & var_list%get_lval (var_str ("?vamp_history_channels")) history_par%channel_verbose = & var_list%get_lval (var_str ("?vamp_history_channels_verbose")) verbose = & var_list%get_lval (var_str ("?vamp_verbose")) check_grid_file = & var_list%get_lval (var_str ("?check_grid_file")) run_id = & var_list%get_sval (var_str ("$run_id")) rebuild_grids = & var_list%get_lval (var_str ("?rebuild_grids")) negative_weights = & var_list%get_lval (var_str ("?negative_weights")) .or. dispatch_nlo end subroutine unpack_options_vamp subroutine unpack_options_vamp2 () mci_vamp2_config%n_bins_max = & var_list%get_ival (var_str ("max_bins")) mci_vamp2_config%n_calls_min_per_channel = & var_list%get_ival (var_str ("min_calls_per_channel")) mci_vamp2_config%n_calls_threshold = & var_list%get_ival (var_str ("threshold_calls")) mci_vamp2_config%beta = & var_list%get_rval (var_str ("channel_weights_power")) mci_vamp2_config%stratified = & var_list%get_lval (var_str ("?stratified")) select case (char (var_list%get_sval (var_str ("$phs_method")))) case ("rambo") mci_vamp2_config%equivalences = .false. case default mci_vamp2_config%equivalences = & var_list%get_lval (var_str ("?use_vamp_equivalences")) end select mci_vamp2_config%accuracy_goal = & var_list%get_rval (var_str ("accuracy_goal")) mci_vamp2_config%error_goal = & var_list%get_rval (var_str ("error_goal")) mci_vamp2_config%rel_error_goal = & var_list%get_rval (var_str ("relative_error_goal")) verbose = & var_list%get_lval (var_str ("?vamp_verbose")) check_grid_file = & var_list%get_lval (var_str ("?check_grid_file")) run_id = & var_list%get_sval (var_str ("$run_id")) rebuild_grids = & var_list%get_lval (var_str ("?rebuild_grids")) negative_weights = & var_list%get_lval (var_str ("?negative_weights")) .or. dispatch_nlo grid_checkpoint = & var_list%get_ival (var_str ("vamp_grid_checkpoint")) select case (char (var_list%get_sval (var_str ("$vamp_grid_format")))) case ("binary","Binary","BINARY") binary_grid_format = .true. case ("ascii","Ascii","ASCII") binary_grid_format = .false. case default binary_grid_format = .false. end select select case (char (var_list%get_sval (var_str ("$vamp_parallel_method")))) case ("simple","Simple","SIMPLE") parallel_method = var_str ("simple") case ("load","Load","LOAD") parallel_method = var_str ("load") case default parallel_method = var_str ("simple") end select end subroutine unpack_options_vamp2 @ @ Make sure that the VAMP grid subdirectory, if requested, exists before it is used. Also include a sanity check on the directory name. <>= character(*), parameter :: ALLOWED_IN_DIRNAME = & "abcdefghijklmnopqrstuvwxyz& &ABCDEFGHIJKLMNOPQRSTUVWXYZ& &1234567890& &.,_-+=" @ %def ALLOWED_IN_DIRNAME <>= public :: setup_grid_path <>= subroutine setup_grid_path (grid_path) type(string_t), intent(in) :: grid_path if (verify (grid_path, ALLOWED_IN_DIRNAME) == 0) then call msg_message ("Integrator: preparing VAMP grid directory '" & // char (grid_path) // "'") call os_system_call ("mkdir -p '" // grid_path // "'") else call msg_fatal ("Integrator: VAMP grid_path '" & // char (grid_path) // "' contains illegal characters") end if end subroutine setup_grid_path @ %def setup_grid_path @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[dispatch_mci_ut.f90]]>>= <> module dispatch_mci_ut use unit_tests use dispatch_mci_uti <> <> contains <> end module dispatch_mci_ut @ %def dispatch_mci_ut @ <<[[dispatch_mci_uti.f90]]>>= <> module dispatch_mci_uti <> <> use variables use mci_base use mci_none use mci_midpoint use mci_vamp use dispatch_mci <> <> contains <> end module dispatch_mci_uti @ %def dispatch_mci_ut @ API: driver for the unit tests below. <>= public ::dispatch_mci_test <>= subroutine dispatch_mci_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine dispatch_mci_test @ %def dispatch_mci_test @ \subsubsection{Select type: integrator core} <>= call test (dispatch_mci_1, "dispatch_mci_1", & "integration method", & u, results) <>= public :: dispatch_mci_1 <>= subroutine dispatch_mci_1 (u) integer, intent(in) :: u type(var_list_t) :: var_list class(mci_t), allocatable :: mci type(string_t) :: process_id write (u, "(A)") "* Test output: dispatch_mci_1" write (u, "(A)") "* Purpose: select integration method" write (u, "(A)") call var_list%init_defaults (0) process_id = "dispatch_mci_1" write (u, "(A)") "* Allocate MCI as none_t" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("none"), is_known = .true.) call dispatch_mci_s (mci, var_list, process_id) select type (mci) type is (mci_none_t) call mci%write (u) end select call mci%final () deallocate (mci) write (u, "(A)") write (u, "(A)") "* Allocate MCI as midpoint_t" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("midpoint"), is_known = .true.) call dispatch_mci_s (mci, var_list, process_id) select type (mci) type is (mci_midpoint_t) call mci%write (u) end select call mci%final () deallocate (mci) write (u, "(A)") write (u, "(A)") "* Allocate MCI as vamp_t" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("vamp"), is_known = .true.) call var_list%set_int (var_str ("threshold_calls"), & 1, is_known = .true.) call var_list%set_int (var_str ("min_calls_per_channel"), & 2, is_known = .true.) call var_list%set_int (var_str ("min_calls_per_bin"), & 3, is_known = .true.) call var_list%set_int (var_str ("min_bins"), & 4, is_known = .true.) call var_list%set_int (var_str ("max_bins"), & 5, is_known = .true.) call var_list%set_log (var_str ("?stratified"), & .false., is_known = .true.) call var_list%set_log (var_str ("?use_vamp_equivalences"),& .false., is_known = .true.) call var_list%set_real (var_str ("channel_weights_power"),& 4._default, is_known = .true.) call var_list%set_log (& var_str ("?vamp_history_global_verbose"), & .true., is_known = .true.) call var_list%set_log (& var_str ("?vamp_history_channels"), & .true., is_known = .true.) call var_list%set_log (& var_str ("?vamp_history_channels_verbose"), & .true., is_known = .true.) call var_list%set_log (var_str ("?stratified"), & .false., is_known = .true.) call dispatch_mci_s (mci, var_list, process_id) select type (mci) type is (mci_vamp_t) call mci%write (u) call mci%write_history_parameters (u) end select call mci%final () deallocate (mci) write (u, "(A)") write (u, "(A)") "* Allocate MCI as vamp_t, allow for negative weights" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("vamp"), is_known = .true.) call var_list%set_log (var_str ("?negative_weights"), & .true., is_known = .true.) call dispatch_mci_s (mci, var_list, process_id) select type (mci) type is (mci_vamp_t) call mci%write (u) call mci%write_history_parameters (u) end select call mci%final () deallocate (mci) call var_list%final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_mci_1" end subroutine dispatch_mci_1 @ %def dispatch_mci_1 Index: trunk/src/variables/variables.nw =================================================================== --- trunk/src/variables/variables.nw (revision 8775) +++ trunk/src/variables/variables.nw (revision 8776) @@ -1,7054 +1,7055 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: variables for processes %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Variables for Processes} \includemodulegraph{variables} This part introduces variables as user-controlled objects that influence the behavior of objects and calculations. Variables contain objects of intrinsic type or of a type as introced above. \begin{description} \item[variables] Store values of various kind, used by expressions and accessed by the command interface. This provides an implementation of the [[vars_t]] abstract type. \item[observables] Concrete implementation of observables (functions in the variable tree), applicable for \whizard. abstract type. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Variables: Implementation} The user interface deals with variables that are handled similarly to full-flegded programming languages. The system will add a lot of predefined variables (model parameters, flags, etc.) that are accessible to the user by the same methods. Variables can be of various type: logical (boolean/flag), integer, real (default precision), subevents (used in cut expressions), arrays of PDG codes (aliases for particles), strings. Furthermore, in cut expressions we have unary and binary observables, which are used like real parameters but behave like functions. <<[[variables.f90]]>>= <> module variables <> <> use io_units + use numeric_utils, only: pacify use format_utils, only: pac_fmt use format_defs, only: FMT_12, FMT_19 use constants, only: eps0 use os_interface, only: paths_t use physics_defs, only: LAMBDA_QCD_REF use system_dependencies use fastjet !NODEP! use diagnostics use pdg_arrays use subevents use var_base <> <> <> <> <> contains <> end module variables @ %def variables @ \subsection{Variable list entries} Variable (and constant) values can be of one of the following types: <>= integer, parameter, public :: V_NONE = 0, V_LOG = 1, V_INT = 2, V_REAL = 3 integer, parameter, public :: V_CMPLX = 4, V_SEV = 5, V_PDG = 6, V_STR = 7 integer, parameter, public :: V_OBS1_INT = 11, V_OBS2_INT = 12 integer, parameter, public :: V_OBS1_REAL = 21, V_OBS2_REAL = 22 integer, parameter, public :: V_OBSEV_INT = 13, V_OBSEV_REAL = 23 integer, parameter, public :: V_UOBS1_INT = 31, V_UOBS2_INT = 32 integer, parameter, public :: V_UOBS1_REAL = 41, V_UOBS2_REAL = 42 @ %def V_NONE V_LOG V_INT V_REAL V_CMPLX V_PRT V_SEV V_PDG V_OBS1_INT @ %def V_OBS2_INT V_OBSEV_INT V_OBS1_REAL V_OBS2_REAL V_OBSEV_REAL @ %def V_UOBS1_INT V_UOBS2_INT V_UOBS1_REAL V_UOBS2_REAL @ \subsubsection{The type} This is an entry in the variable list. It can be of any type; in each case only one value is allocated. It may be physically allocated upon creation, in which case [[is_allocated]] is true, or it may contain just a pointer to a value somewhere else, in which case [[is_allocated]] is false. The flag [[is_defined]] is set when the variable is given a value, even the undefined value. (Therefore it is distinct from [[is_known]].) This matters for variable declaration in the SINDARIN language. The variable is set up in the compilation step and initially marked as defined, but after compilation all variables are set undefined. Each variable becomes defined when it is explicitly set. The difference matters in loops. [[is_locked]] means that it cannot be given a value using the interface routines [[var_list_set_XXX]] below. It can only be initialized, or change automatically due to a side effect. [[is_copy]] means that this is a local copy of a global variable. The copy has a pointer to the original, which can be used to restore a previous value. [[is_intrinsic]] means that this variable is defined by the program, not by the user. Intrinsic variables cannot be (re)declared, but their values can be reset unless they are locked. [[is_user_var]] means that the variable has been declared by the user. It could be a new variable, or a local copy of an intrinsic variable. The flag [[is_known]] is a pointer which parallels the use of the value pointer. For pointer variables, it is set if the value should point to a known value. For ordinary variables, it should be true. The value is implemented as a set of alternative type-specific pointers. This emulates polymorphism, and it allows for actual pointer variables. Observable-type variables have function pointers as values, so they behave like macros. The functions make use of the particle objects accessible via the pointers [[prt1]] and [[prt2]]. Finally, the [[next]] pointer indicates that we are making lists of variables. A more efficient implementation might switch to hashes or similar; the current implementation has $O(N)$ lookup. <>= public :: var_entry_t <>= type :: var_entry_t private integer :: type = V_NONE type(string_t) :: name logical :: is_allocated = .false. logical :: is_defined = .false. logical :: is_locked = .false. logical :: is_intrinsic = .false. logical :: is_user_var = .false. logical, pointer :: is_known => null () logical, pointer :: lval => null () integer, pointer :: ival => null () real(default), pointer :: rval => null () complex(default), pointer :: cval => null () type(subevt_t), pointer :: pval => null () type(pdg_array_t), pointer :: aval => null () type(string_t), pointer :: sval => null () procedure(obs_unary_int), nopass, pointer :: obs1_int => null () procedure(obs_unary_real), nopass, pointer :: obs1_real => null () procedure(obs_binary_int), nopass, pointer :: obs2_int => null () procedure(obs_binary_real), nopass, pointer :: obs2_real => null () procedure(obs_sev_int), nopass, pointer :: obsev_int => null () procedure(obs_sev_real), nopass, pointer :: obsev_real => null () type(prt_t), pointer :: prt1 => null () type(prt_t), pointer :: prt2 => null () type(var_entry_t), pointer :: next => null () type(var_entry_t), pointer :: previous => null () type(string_t) :: description end type var_entry_t @ %def var_entry_t @ \subsubsection{Interfaces for the observable functions} <>= public :: obs_unary_int public :: obs_unary_real public :: obs_binary_int public :: obs_binary_real public :: obs_sev_int public :: obs_sev_real <>= abstract interface function obs_unary_int (prt1) result (ival) import integer :: ival type(prt_t), intent(in) :: prt1 end function obs_unary_int end interface abstract interface function obs_unary_real (prt1) result (rval) import real(default) :: rval type(prt_t), intent(in) :: prt1 end function obs_unary_real end interface abstract interface function obs_binary_int (prt1, prt2) result (ival) import integer :: ival type(prt_t), intent(in) :: prt1, prt2 end function obs_binary_int end interface abstract interface function obs_binary_real (prt1, prt2) result (rval) import real(default) :: rval type(prt_t), intent(in) :: prt1, prt2 end function obs_binary_real end interface abstract interface function obs_sev_int (sev) result (ival) import integer :: ival type(subevt_t), intent(in) :: sev end function obs_sev_int end interface abstract interface function obs_sev_real (sev) result (rval) import real(default) :: rval type(subevt_t), intent(in) :: sev end function obs_sev_real end interface @ %def obs_unary_int obs_unary_real @ %def obs_binary_int obs_binary_real @ %def obs_sev_int obs_sev_real @ \subsubsection{Initialization} Initialize an entry, optionally with a physical value. We also allocate the [[is_known]] flag and set it if the value is set. <>= public :: var_entry_init_int <>= subroutine var_entry_init_log (var, name, lval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_LOG allocate (var%lval, var%is_known) if (present (lval)) then var%lval = lval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_log subroutine var_entry_init_int (var, name, ival, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_INT allocate (var%ival, var%is_known) if (present (ival)) then var%ival = ival var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_int subroutine var_entry_init_real (var, name, rval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_REAL allocate (var%rval, var%is_known) if (present (rval)) then var%rval = rval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_real subroutine var_entry_init_cmplx (var, name, cval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_CMPLX allocate (var%cval, var%is_known) if (present (cval)) then var%cval = cval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_cmplx subroutine var_entry_init_subevt (var, name, pval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_SEV allocate (var%pval, var%is_known) if (present (pval)) then var%pval = pval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_subevt subroutine var_entry_init_pdg_array (var, name, aval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_PDG allocate (var%aval, var%is_known) if (present (aval)) then var%aval = aval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_pdg_array subroutine var_entry_init_string (var, name, sval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(string_t), intent(in), optional :: sval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_STR allocate (var%sval, var%is_known) if (present (sval)) then var%sval = sval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_string @ %def var_entry_init_log @ %def var_entry_init_int @ %def var_entry_init_real @ %def var_entry_init_cmplx @ %def var_entry_init_subevt @ %def var_entry_init_pdg_array @ %def var_entry_init_string @ Initialize an entry with a pointer to the value and, for numeric/logical values, a pointer to the [[is_known]] flag. <>= subroutine var_entry_init_log_ptr (var, name, lval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name logical, intent(in), target :: lval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_LOG var%lval => lval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_log_ptr subroutine var_entry_init_int_ptr (var, name, ival, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in), target :: ival logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_INT var%ival => ival var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_int_ptr subroutine var_entry_init_real_ptr (var, name, rval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name real(default), intent(in), target :: rval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_REAL var%rval => rval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_real_ptr subroutine var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name complex(default), intent(in), target :: cval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_CMPLX var%cval => cval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_cmplx_ptr subroutine var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(pdg_array_t), intent(in), target :: aval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_PDG var%aval => aval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_pdg_array_ptr subroutine var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(subevt_t), intent(in), target :: pval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_SEV var%pval => pval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_subevt_ptr subroutine var_entry_init_string_ptr (var, name, sval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(string_t), intent(in), target :: sval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_STR var%sval => sval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_string_ptr @ %def var_entry_init_log_ptr @ %def var_entry_init_int_ptr @ %def var_entry_init_real_ptr @ %def var_entry_init_cmplx_ptr @ %def var_entry_init_pdg_array_ptr @ %def var_entry_init_subevt_ptr @ %def var_entry_init_string_ptr @ Initialize an entry with an observable. The procedure pointer is not yet set. <>= subroutine var_entry_init_obs (var, name, type, prt1, prt2) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in) :: type type(prt_t), intent(in), target :: prt1 type(prt_t), intent(in), optional, target :: prt2 var%type = type var%name = name var%prt1 => prt1 if (present (prt2)) var%prt2 => prt2 var%is_intrinsic = .true. var%is_defined = .true. end subroutine var_entry_init_obs subroutine var_entry_init_obs_sev (var, name, type, pval) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in) :: type type(subevt_t), intent(in), target :: pval var%type = type var%name = name var%pval => pval var%is_intrinsic = .true. var%is_defined = .true. end subroutine var_entry_init_obs_sev @ %def var_entry_init_obs var_entry_init_obs_sev @ Mark an entry as undefined it it is a user-defined variable object, so force re-initialization. <>= subroutine var_entry_undefine (var) type(var_entry_t), intent(inout) :: var var%is_defined = .not. var%is_user_var var%is_known = var%is_defined .and. var%is_known end subroutine var_entry_undefine @ %def var_entry_undefine @ Clear an entry: mark it as unknown. <>= subroutine var_entry_clear (var) type(var_entry_t), intent(inout) :: var var%is_known = .false. end subroutine var_entry_clear @ %def var_entry_clear @ Lock an entry: forbid resetting the entry after initialization. <>= subroutine var_entry_lock (var, locked) type(var_entry_t), intent(inout) :: var logical, intent(in), optional :: locked if (present (locked)) then var%is_locked = locked else var%is_locked = .true. end if end subroutine var_entry_lock @ %def var_entry_lock @ \subsubsection{Finalizer} <>= subroutine var_entry_final (var) type(var_entry_t), intent(inout) :: var if (var%is_allocated) then select case (var%type) case (V_LOG); deallocate (var%lval) case (V_INT); deallocate (var%ival) case (V_REAL);deallocate (var%rval) case (V_CMPLX);deallocate (var%cval) case (V_SEV); deallocate (var%pval) case (V_PDG); deallocate (var%aval) case (V_STR); deallocate (var%sval) end select deallocate (var%is_known) var%is_allocated = .false. var%is_defined = .false. end if end subroutine var_entry_final @ %def var_entry_final @ \subsubsection{Output} <>= recursive subroutine var_entry_write (var, unit, model_name, & intrinsic, pacified, descriptions, ascii_output) type(var_entry_t), intent(in) :: var integer, intent(in), optional :: unit type(string_t), intent(in), optional :: model_name logical, intent(in), optional :: intrinsic logical, intent(in), optional :: pacified logical, intent(in), optional :: descriptions logical, intent(in), optional :: ascii_output type(string_t) :: col_string logical :: show_desc, ao integer :: u u = given_output_unit (unit); if (u < 0) return show_desc = .false.; if (present (descriptions)) show_desc = descriptions ao = .false.; if (present (ascii_output)) ao = ascii_output if (show_desc) then if (ao) then col_string = create_col_string (COL_BLUE) if (var%is_locked) then write (u, "(A)", advance="no") char (achar(27) // col_string) // & char (var%name) // achar(27) // "[0m" //" fixed-value=" else write (u, "(A)", advance="no") char (achar(27) // col_string) // & char (var%name) // achar(27) // "[0m" //" default=" end if col_string = create_col_string (COL_RED) write (u, "(A)", advance="no") char (achar(27) // col_string) call var_write_val (var, u, "no", pacified=.true.) write (u, "(A)") achar(27) // "[0m" write (u, "(A)") char (var%description) return else write (u, "(A)") "\item" write (u, "(A)", advance="no") "\ttt{" // char ( & replace (replace (var%name, "_", "\_", every=.true.), "$", "\$" )) // & "} " if (var%is_known) then if (var%is_locked) then write (u, "(A)", advance="no") "\qquad (fixed value: \ttt{" else write (u, "(A)", advance="no") "\qquad (default: \ttt{" end if call var_write_val (var, u, "no", pacified=.true., escape_tex=.true.) write (u, "(A)", advance="no") "})" end if write (u, "(A)") " \newline" write (u, "(A)") char (var%description) write (u, "(A)") "%%%%%" return end if end if if (present (intrinsic)) then if (var%is_intrinsic .neqv. intrinsic) return end if if (.not. var%is_defined) then write (u, "(A,1x)", advance="no") "[undefined]" end if if (.not. var%is_intrinsic) then write (u, "(A,1x)", advance="no") "[user variable]" end if if (present (model_name)) then write (u, "(A,A)", advance="no") char(model_name), "." end if write (u, "(A)", advance="no") char (var%name) if (var%is_locked) write (u, "(A)", advance="no") "*" if (var%is_allocated) then write (u, "(A)", advance="no") " = " else if (var%type /= V_NONE) then write (u, "(A)", advance="no") " => " end if call var_write_val (var, u, "yes", pacified) end subroutine var_entry_write @ %def var_entry_write @ <>= subroutine var_write_val (var, u, advance, pacified, escape_tex) type(var_entry_t), intent(in) :: var integer, intent(in) :: u character(*), intent(in) :: advance logical, intent(in), optional :: pacified, escape_tex logical :: num_pac, et real(default) :: rval complex(default) :: cval character(len=7) :: fmt call pac_fmt (fmt, FMT_19, FMT_12, pacified) num_pac = .false.; if (present (pacified)) num_pac = pacified et = .false.; if (present (escape_tex)) et = escape_tex select case (var%type) case (V_NONE); write (u, '()', advance=advance) case (V_LOG) if (var%is_known) then if (var%lval) then write (u, "(A)", advance=advance) "true" else write (u, "(A)", advance=advance) "false" end if else write (u, "(A)", advance=advance) "[unknown logical]" end if case (V_INT) if (var%is_known) then write (u, "(I0)", advance=advance) var%ival else write (u, "(A)", advance=advance) "[unknown integer]" end if case (V_REAL) if (var%is_known) then rval = var%rval if (num_pac) then call pacify (rval, 10 * eps0) end if write (u, "(" // fmt // ")", advance=advance) rval else write (u, "(A)", advance=advance) "[unknown real]" end if case (V_CMPLX) if (var%is_known) then cval = var%cval if (num_pac) then call pacify (cval, 10 * eps0) end if write (u, "('('," // fmt // ",','," // fmt // ",')')", advance=advance) cval else write (u, "(A)", advance=advance) "[unknown complex]" end if case (V_SEV) if (var%is_known) then call subevt_write (var%pval, u, prefix=" ", & pacified = pacified) else write (u, "(A)", advance=advance) "[unknown subevent]" end if case (V_PDG) if (var%is_known) then call pdg_array_write (var%aval, u); write (u, *) else write (u, "(A)", advance=advance) "[unknown PDG array]" end if case (V_STR) if (var%is_known) then if (et) then write (u, "(A)", advance=advance) '"' // char (replace ( & replace (var%sval, "_", "\_", every=.true.), "$", "\$" )) // '"' else write (u, "(A)", advance=advance) '"' // char (var%sval) // '"' end if else write (u, "(A)", advance=advance) "[unknown string]" end if case (V_OBS1_INT); write (u, "(A)", advance=advance) "[int] = unary observable" case (V_OBS2_INT); write (u, "(A)", advance=advance) "[int] = binary observable" case (V_OBSEV_INT); write (u, "(A)", advance=advance) "[int] = subeventary observable" case (V_OBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary observable" case (V_OBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary observable" case (V_OBSEV_REAL); write (u, "(A)", advance=advance) "[real] = subeventary observable" case (V_UOBS1_INT); write (u, "(A)", advance=advance) "[int] = unary user observable" case (V_UOBS2_INT); write (u, "(A)", advance=advance) "[int] = binary user observable" case (V_UOBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary user observable" case (V_UOBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary user observable" end select end subroutine var_write_val @ %def procedure @ \subsubsection{Accessing contents} <>= function var_entry_get_name (var) result (name) type(string_t) :: name type(var_entry_t), intent(in) :: var name = var%name end function var_entry_get_name function var_entry_get_type (var) result (type) integer :: type type(var_entry_t), intent(in) :: var type = var%type end function var_entry_get_type @ %def var_entry_get_name var_entry_get_type @ Return true if the variable is defined. This the case if it is allocated and known, or if it is a pointer. <>= function var_entry_is_defined (var) result (defined) logical :: defined type(var_entry_t), intent(in) :: var defined = var%is_defined end function var_entry_is_defined @ %def var_entry_is_defined @ Return true if the variable is locked. If [[force]] is active, always return false. <>= function var_entry_is_locked (var, force) result (locked) logical :: locked type(var_entry_t), intent(in) :: var logical, intent(in), optional :: force if (present (force)) then if (force) then locked = .false.; return end if end if locked = var%is_locked end function var_entry_is_locked @ %def var_entry_is_locked @ Return true if the variable is intrinsic <>= function var_entry_is_intrinsic (var) result (flag) logical :: flag type(var_entry_t), intent(in) :: var flag = var%is_intrinsic end function var_entry_is_intrinsic @ %def var_entry_is_intrinsic @ Return components <>= function var_entry_is_known (var) result (flag) logical :: flag type(var_entry_t), intent(in) :: var flag = var%is_known end function var_entry_is_known function var_entry_get_lval (var) result (lval) logical :: lval type(var_entry_t), intent(in) :: var lval = var%lval end function var_entry_get_lval function var_entry_get_ival (var) result (ival) integer :: ival type(var_entry_t), intent(in) :: var ival = var%ival end function var_entry_get_ival function var_entry_get_rval (var) result (rval) real(default) :: rval type(var_entry_t), intent(in) :: var rval = var%rval end function var_entry_get_rval function var_entry_get_cval (var) result (cval) complex(default) :: cval type(var_entry_t), intent(in) :: var cval = var%cval end function var_entry_get_cval function var_entry_get_aval (var) result (aval) type(pdg_array_t) :: aval type(var_entry_t), intent(in) :: var aval = var%aval end function var_entry_get_aval function var_entry_get_pval (var) result (pval) type(subevt_t) :: pval type(var_entry_t), intent(in) :: var pval = var%pval end function var_entry_get_pval function var_entry_get_sval (var) result (sval) type(string_t) :: sval type(var_entry_t), intent(in) :: var sval = var%sval end function var_entry_get_sval @ %def var_entry_get_lval @ %def var_entry_get_ival @ %def var_entry_get_rval @ %def var_entry_get_cval @ %def var_entry_get_aval @ %def var_entry_get_pval @ %def var_entry_get_sval @ Return pointers to components. <>= function var_entry_get_known_ptr (var) result (ptr) logical, pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%is_known end function var_entry_get_known_ptr function var_entry_get_lval_ptr (var) result (ptr) logical, pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%lval end function var_entry_get_lval_ptr function var_entry_get_ival_ptr (var) result (ptr) integer, pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%ival end function var_entry_get_ival_ptr function var_entry_get_rval_ptr (var) result (ptr) real(default), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%rval end function var_entry_get_rval_ptr function var_entry_get_cval_ptr (var) result (ptr) complex(default), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%cval end function var_entry_get_cval_ptr function var_entry_get_pval_ptr (var) result (ptr) type(subevt_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%pval end function var_entry_get_pval_ptr function var_entry_get_aval_ptr (var) result (ptr) type(pdg_array_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%aval end function var_entry_get_aval_ptr function var_entry_get_sval_ptr (var) result (ptr) type(string_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%sval end function var_entry_get_sval_ptr @ %def var_entry_get_known_ptr @ %def var_entry_get_lval_ptr var_entry_get_ival_ptr var_entry_get_rval_ptr @ %def var_entry_get_cval_ptr var_entry_get_aval_ptr var_entry_get_pval_ptr @ %def var_entry_get_sval_ptr @ Furthermore, <>= function var_entry_get_prt1_ptr (var) result (ptr) type(prt_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%prt1 end function var_entry_get_prt1_ptr function var_entry_get_prt2_ptr (var) result (ptr) type(prt_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%prt2 end function var_entry_get_prt2_ptr @ %def var_entry_get_prt1_ptr @ %def var_entry_get_prt2_ptr @ Subroutines might be safer than functions for procedure pointer transfer. <>= subroutine var_entry_assign_obs1_int_ptr (ptr, var) procedure(obs_unary_int), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs1_int end subroutine var_entry_assign_obs1_int_ptr subroutine var_entry_assign_obs1_real_ptr (ptr, var) procedure(obs_unary_real), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs1_real end subroutine var_entry_assign_obs1_real_ptr subroutine var_entry_assign_obs2_int_ptr (ptr, var) procedure(obs_binary_int), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs2_int end subroutine var_entry_assign_obs2_int_ptr subroutine var_entry_assign_obs2_real_ptr (ptr, var) procedure(obs_binary_real), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs2_real end subroutine var_entry_assign_obs2_real_ptr subroutine var_entry_assign_obsev_int_ptr (ptr, var) procedure(obs_sev_int), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obsev_int end subroutine var_entry_assign_obsev_int_ptr subroutine var_entry_assign_obsev_real_ptr (ptr, var) procedure(obs_sev_real), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obsev_real end subroutine var_entry_assign_obsev_real_ptr @ %def var_entry_assign_obs1_int_ptr var_entry_assign_obs1_real_ptr @ %def var_entry_assign_obs2_int_ptr var_entry_assign_obs2_real_ptr @ %def var_entry_assigbn_obsev_int_ptr var_entry_assign_obsev_real_ptr @ \subsection{Setting values} Undefine the value. <>= subroutine var_entry_clear_value (var) type(var_entry_t), intent(inout) :: var var%is_known = .false. end subroutine var_entry_clear_value @ %def var_entry_clear_value <>= recursive subroutine var_entry_set_log & (var, lval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var logical, intent(in) :: lval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%lval = lval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_log recursive subroutine var_entry_set_int & (var, ival, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var integer, intent(in) :: ival logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%ival = ival var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_int recursive subroutine var_entry_set_real & (var, rval, is_known, verbose, model_name, pacified) type(var_entry_t), intent(inout) :: var real(default), intent(in) :: rval logical, intent(in) :: is_known logical, intent(in), optional :: verbose, pacified type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%rval = rval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write & (var, model_name=model_name, pacified = pacified) call var_entry_write & (var, model_name=model_name, unit=u, pacified = pacified) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_real recursive subroutine var_entry_set_cmplx & (var, cval, is_known, verbose, model_name, pacified) type(var_entry_t), intent(inout) :: var complex(default), intent(in) :: cval logical, intent(in) :: is_known logical, intent(in), optional :: verbose, pacified type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%cval = cval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write & (var, model_name=model_name, pacified = pacified) call var_entry_write & (var, model_name=model_name, unit=u, pacified = pacified) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_cmplx recursive subroutine var_entry_set_pdg_array & (var, aval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var type(pdg_array_t), intent(in) :: aval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%aval = aval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_pdg_array recursive subroutine var_entry_set_subevt & (var, pval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var type(subevt_t), intent(in) :: pval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%pval = pval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_subevt recursive subroutine var_entry_set_string & (var, sval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var type(string_t), intent(in) :: sval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%sval = sval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_string @ %def var_entry_set_log @ %def var_entry_set_int @ %def var_entry_set_real @ %def var_entry_set_cmplx @ %def var_entry_set_pdg_array @ %def var_entry_set_subevt @ %def var_entry_set_string @ <>= public :: var_entry_set_description <>= pure subroutine var_entry_set_description (var_entry, description) type(var_entry_t), intent(inout) :: var_entry type(string_t), intent(in) :: description var_entry%description = description end subroutine var_entry_set_description @ %def var_entry_set_description @ \subsection{Copies and pointer variables} Initialize an entry with a copy of an existing variable entry. The copy is physically allocated with the same type as the original. <>= subroutine var_entry_init_copy (var, original, user) type(var_entry_t), intent(out) :: var type(var_entry_t), intent(in), target :: original logical, intent(in), optional :: user type(string_t) :: name logical :: intrinsic name = var_entry_get_name (original) intrinsic = original%is_intrinsic select case (original%type) case (V_LOG) call var_entry_init_log (var, name, intrinsic=intrinsic, user=user) case (V_INT) call var_entry_init_int (var, name, intrinsic=intrinsic, user=user) case (V_REAL) call var_entry_init_real (var, name, intrinsic=intrinsic, user=user) case (V_CMPLX) call var_entry_init_cmplx (var, name, intrinsic=intrinsic, user=user) case (V_SEV) call var_entry_init_subevt (var, name, intrinsic=intrinsic, user=user) case (V_PDG) call var_entry_init_pdg_array (var, name, intrinsic=intrinsic, user=user) case (V_STR) call var_entry_init_string (var, name, intrinsic=intrinsic, user=user) end select end subroutine var_entry_init_copy @ %def var_entry_init_copy @ Copy the value of an entry. The target variable entry must be initialized correctly. <>= subroutine var_entry_copy_value (var, original) type(var_entry_t), intent(inout) :: var type(var_entry_t), intent(in), target :: original if (var_entry_is_known (original)) then select case (original%type) case (V_LOG) call var_entry_set_log (var, var_entry_get_lval (original), .true.) case (V_INT) call var_entry_set_int (var, var_entry_get_ival (original), .true.) case (V_REAL) call var_entry_set_real (var, var_entry_get_rval (original), .true.) case (V_CMPLX) call var_entry_set_cmplx (var, var_entry_get_cval (original), .true.) case (V_SEV) call var_entry_set_subevt (var, var_entry_get_pval (original), .true.) case (V_PDG) call var_entry_set_pdg_array (var, var_entry_get_aval (original), .true.) case (V_STR) call var_entry_set_string (var, var_entry_get_sval (original), .true.) end select else call var_entry_clear (var) end if end subroutine var_entry_copy_value @ %def var_entry_copy_value @ \subsection{Variable lists} \subsubsection{The type} Variable lists can be linked together. No initializer needed. They are deleted separately. <>= public :: var_list_t <>= type, extends (vars_t) :: var_list_t private type(var_entry_t), pointer :: first => null () type(var_entry_t), pointer :: last => null () type(var_list_t), pointer :: next => null () contains <> end type var_list_t @ %def var_list_t @ \subsubsection{Constructors} Implementation of the [[link]] deferred method. The implementation restricts itself to var lists of the same type. We might need to relax this constraint. <>= procedure :: link => var_list_link <>= subroutine var_list_link (vars, target_vars) class(var_list_t), intent(inout) :: vars class(vars_t), intent(in), target :: target_vars select type (target_vars) type is (var_list_t) vars%next => target_vars class default call msg_bug ("var_list_link: unsupported target type") end select end subroutine var_list_link @ %def var_list_link @ Append a new entry to an existing list. <>= subroutine var_list_append (var_list, var, verbose) type(var_list_t), intent(inout), target :: var_list type(var_entry_t), intent(inout), target :: var logical, intent(in), optional :: verbose if (associated (var_list%last)) then var%previous => var_list%last var_list%last%next => var else var%previous => null () var_list%first => var end if var_list%last => var if (present (verbose)) then if (verbose) call var_entry_write (var) end if end subroutine var_list_append @ %def var_list_append @ Sort a list. <>= procedure :: sort => var_list_sort <>= subroutine var_list_sort (var_list) class(var_list_t), intent(inout) :: var_list type(var_entry_t), pointer :: var, previous if (associated (var_list%first)) then var => var_list%first do while (associated (var)) previous => var%previous do while (associated (previous)) if (larger_var (previous, var)) then call var_list%swap_with_next (previous) end if previous => previous%previous end do var => var%next end do end if end subroutine var_list_sort @ %def var_list_sort @ <>= pure function larger_var (var1, var2) result (larger) logical :: larger type(var_entry_t), intent(in) :: var1, var2 type(string_t) :: str1, str2 str1 = replace (var1%name, "?", "") str1 = replace (str1, "$", "") str2 = replace (var2%name, "?", "") str2 = replace (str2, "$", "") larger = str1 > str2 end function larger_var @ %def larger_var @ <>= procedure :: get_previous => var_list_get_previous <>= function var_list_get_previous (var_list, var_entry) result (previous) type(var_entry_t), pointer :: previous class(var_list_t), intent(in) :: var_list type(var_entry_t), intent(in) :: var_entry previous => var_list%first if (previous%name == var_entry%name) then previous => null () else do while (associated (previous)) if (previous%next%name == var_entry%name) exit previous => previous%next end do end if end function var_list_get_previous @ %def var_list_get_previous @ <>= procedure :: swap_with_next => var_list_swap_with_next <>= subroutine var_list_swap_with_next (var_list, var_entry) class(var_list_t), intent(inout) :: var_list type(var_entry_t), intent(in) :: var_entry type(var_entry_t), pointer :: previous, this, next, next_next previous => var_list%get_previous (var_entry) if (.not. associated (previous)) then this => var_list%first else this => previous%next end if next => this%next next_next => next%next if (associated (previous)) then previous%next => next next%previous => previous else var_list%first => next next%previous => null () end if this%next => next_next if (associated (next_next)) then next_next%previous => this end if next%next => this this%previous => next if (.not. associated (next%next)) then var_list%last => next end if end subroutine var_list_swap_with_next @ %def var_list_swap_with_next @ Public methods for expanding the variable list (as subroutines) <>= generic :: append_log => var_list_append_log_s, var_list_append_log_c procedure, private :: var_list_append_log_s procedure, private :: var_list_append_log_c generic :: append_int => var_list_append_int_s, var_list_append_int_c procedure, private :: var_list_append_int_s procedure, private :: var_list_append_int_c generic :: append_real => var_list_append_real_s, var_list_append_real_c procedure, private :: var_list_append_real_s procedure, private :: var_list_append_real_c generic :: append_cmplx => var_list_append_cmplx_s, var_list_append_cmplx_c procedure, private :: var_list_append_cmplx_s procedure, private :: var_list_append_cmplx_c generic :: append_subevt => var_list_append_subevt_s, var_list_append_subevt_c procedure, private :: var_list_append_subevt_s procedure, private :: var_list_append_subevt_c generic :: append_pdg_array => var_list_append_pdg_array_s, var_list_append_pdg_array_c procedure, private :: var_list_append_pdg_array_s procedure, private :: var_list_append_pdg_array_c generic :: append_string => var_list_append_string_s, var_list_append_string_c procedure, private :: var_list_append_string_s procedure, private :: var_list_append_string_c <>= public :: var_list_append_log public :: var_list_append_int public :: var_list_append_real public :: var_list_append_cmplx public :: var_list_append_subevt public :: var_list_append_pdg_array public :: var_list_append_string <>= interface var_list_append_log module procedure var_list_append_log_s module procedure var_list_append_log_c end interface interface var_list_append_int module procedure var_list_append_int_s module procedure var_list_append_int_c end interface interface var_list_append_real module procedure var_list_append_real_s module procedure var_list_append_real_c end interface interface var_list_append_cmplx module procedure var_list_append_cmplx_s module procedure var_list_append_cmplx_c end interface interface var_list_append_subevt module procedure var_list_append_subevt_s module procedure var_list_append_subevt_c end interface interface var_list_append_pdg_array module procedure var_list_append_pdg_array_s module procedure var_list_append_pdg_array_c end interface interface var_list_append_string module procedure var_list_append_string_s module procedure var_list_append_string_c end interface <>= subroutine var_list_append_log_s & (var_list, name, lval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_log (var, name, lval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_log_s subroutine var_list_append_int_s & (var_list, name, ival, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_int (var, name, ival, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_int_s subroutine var_list_append_real_s & (var_list, name, rval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_real (var, name, rval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_real_s subroutine var_list_append_cmplx_s & (var_list, name, cval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_cmplx (var, name, cval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_cmplx_s subroutine var_list_append_subevt_s & (var_list, name, pval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_subevt (var, name, pval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_subevt_s subroutine var_list_append_pdg_array_s & (var_list, name, aval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_pdg_array (var, name, aval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_pdg_array_s subroutine var_list_append_string_s & (var_list, name, sval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(string_t), intent(in), optional :: sval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_string (var, name, sval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_string_s subroutine var_list_append_log_c & (var_list, name, lval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_log_s & (var_list, var_str (name), lval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_log_c subroutine var_list_append_int_c & (var_list, name, ival, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_int_s & (var_list, var_str (name), ival, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_int_c subroutine var_list_append_real_c & (var_list, name, rval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_real_s & (var_list, var_str (name), rval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_real_c subroutine var_list_append_cmplx_c & (var_list, name, cval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_cmplx_s & (var_list, var_str (name), cval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_cmplx_c subroutine var_list_append_subevt_c & (var_list, name, pval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_subevt_s & (var_list, var_str (name), pval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_subevt_c subroutine var_list_append_pdg_array_c & (var_list, name, aval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_pdg_array_s & (var_list, var_str (name), aval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_pdg_array_c subroutine var_list_append_string_c & (var_list, name, sval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name character(*), intent(in), optional :: sval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description if (present (sval)) then call var_list_append_string_s & (var_list, var_str (name), var_str (sval), & locked, verbose, intrinsic, user, description) else call var_list_append_string_s & (var_list, var_str (name), & locked=locked, verbose=verbose, intrinsic=intrinsic, & user=user, description=description) end if end subroutine var_list_append_string_c @ %def var_list_append_log @ %def var_list_append_int @ %def var_list_append_real @ %def var_list_append_cmplx @ %def var_list_append_subevt @ %def var_list_append_pdg_array @ %def var_list_append_string <>= public :: var_list_append_log_ptr public :: var_list_append_int_ptr public :: var_list_append_real_ptr public :: var_list_append_cmplx_ptr public :: var_list_append_pdg_array_ptr public :: var_list_append_subevt_ptr public :: var_list_append_string_ptr <>= procedure :: append_log_ptr => var_list_append_log_ptr procedure :: append_int_ptr => var_list_append_int_ptr procedure :: append_real_ptr => var_list_append_real_ptr procedure :: append_cmplx_ptr => var_list_append_cmplx_ptr procedure :: append_pdg_array_ptr => var_list_append_pdg_array_ptr procedure :: append_subevt_ptr => var_list_append_subevt_ptr procedure :: append_string_ptr => var_list_append_string_ptr <>= subroutine var_list_append_log_ptr & (var_list, name, lval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name logical, intent(in), target :: lval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_log_ptr (var, name, lval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_log_ptr subroutine var_list_append_int_ptr & (var_list, name, ival, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name integer, intent(in), target :: ival logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_int_ptr (var, name, ival, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_int_ptr subroutine var_list_append_real_ptr & (var_list, name, rval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name real(default), intent(in), target :: rval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_real_ptr (var, name, rval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_real_ptr subroutine var_list_append_cmplx_ptr & (var_list, name, cval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name complex(default), intent(in), target :: cval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_cmplx_ptr subroutine var_list_append_pdg_array_ptr & (var_list, name, aval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in), target :: aval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_pdg_array_ptr subroutine var_list_append_subevt_ptr & (var_list, name, pval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in), target :: pval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_subevt_ptr subroutine var_list_append_string_ptr & (var_list, name, sval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(string_t), intent(in), target :: sval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_string_ptr (var, name, sval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_string_ptr @ %def var_list_append_log_ptr @ %def var_list_append_int_ptr @ %def var_list_append_real_ptr @ %def var_list_append_cmplx_ptr @ %def var_list_append_pdg_array_ptr @ %def var_list_append_subevt_ptr @ \subsubsection{Finalizer} Finalize, delete the list entry by entry. The link itself is kept intact. Follow link and delete recursively only if requested explicitly. <>= procedure :: final => var_list_final <>= recursive subroutine var_list_final (vars, follow_link) class(var_list_t), intent(inout) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var vars%last => null () do while (associated (vars%first)) var => vars%first vars%first => var%next call var_entry_final (var) deallocate (var) end do if (present (follow_link)) then if (follow_link) then if (associated (vars%next)) then call vars%next%final (follow_link) deallocate (vars%next) end if end if end if end subroutine var_list_final @ %def var_list_final @ \subsubsection{Output} Show variable list with precise control over options. E.g., show only variables of a certain type. Many options, thus not an ordinary [[write]] method. <>= public :: var_list_write <>= procedure :: write => var_list_write <>= recursive subroutine var_list_write & (var_list, unit, follow_link, only_type, prefix, model_name, & intrinsic, pacified, descriptions, ascii_output) class(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: unit logical, intent(in), optional :: follow_link integer, intent(in), optional :: only_type character(*), intent(in), optional :: prefix type(string_t), intent(in), optional :: model_name logical, intent(in), optional :: intrinsic logical, intent(in), optional :: pacified logical, intent(in), optional :: descriptions logical, intent(in), optional :: ascii_output type(var_entry_t), pointer :: var integer :: u, length logical :: write_this, write_next u = given_output_unit (unit); if (u < 0) return if (present (prefix)) length = len (prefix) var => var_list%first if (associated (var)) then do while (associated (var)) if (present (only_type)) then write_this = only_type == var%type else write_this = .true. end if if (write_this .and. present (prefix)) then if (prefix /= extract (var%name, 1, length)) & write_this = .false. end if if (write_this) then call var_entry_write & (var, unit, model_name=model_name, & intrinsic=intrinsic, pacified=pacified, & descriptions=descriptions, ascii_output=ascii_output) end if var => var%next end do end if if (present (follow_link)) then write_next = follow_link .and. associated (var_list%next) else write_next = associated (var_list%next) end if if (write_next) then call var_list_write (var_list%next, & unit, follow_link, only_type, prefix, model_name, & intrinsic, pacified) end if end subroutine var_list_write @ %def var_list_write @ Write only a certain variable. <>= public :: var_list_write_var <>= procedure :: write_var => var_list_write_var <>= recursive subroutine var_list_write_var & (var_list, name, unit, type, follow_link, & model_name, pacified, defined, descriptions, ascii_output) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(in), optional :: unit integer, intent(in), optional :: type logical, intent(in), optional :: follow_link type(string_t), intent(in), optional :: model_name logical, intent(in), optional :: pacified logical, intent(in), optional :: defined logical, intent(in), optional :: descriptions logical, intent(in), optional :: ascii_output type(var_entry_t), pointer :: var integer :: u u = given_output_unit (unit); if (u < 0) return var => var_list_get_var_ptr & (var_list, name, type, follow_link=follow_link, defined=defined) if (associated (var)) then call var_entry_write & (var, unit, model_name = model_name, & pacified = pacified, & descriptions=descriptions, ascii_output=ascii_output) else write (u, "(A)") char (name) // " = [undefined]" end if end subroutine var_list_write_var @ %def var_list_write_var @ \subsection{Tools} Return a pointer to the variable list linked to by the current one. <>= function var_list_get_next_ptr (var_list) result (next_ptr) type(var_list_t), pointer :: next_ptr type(var_list_t), intent(in) :: var_list next_ptr => var_list%next end function var_list_get_next_ptr @ %def var_list_get_next_ptr @ Used by [[eval_trees]]: Return a pointer to the variable with the requested name. If no such name exists, return a null pointer. In that case, try the next list if present, unless [[follow_link]] is unset. If [[defined]] is set, ignore entries that exist but are undefined. <>= public :: var_list_get_var_ptr <>= recursive function var_list_get_var_ptr & (var_list, name, type, follow_link, defined) result (var) type(var_entry_t), pointer :: var type(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(in), optional :: type logical, intent(in), optional :: follow_link, defined logical :: ignore_undef, search_next ignore_undef = .true.; if (present (defined)) ignore_undef = .not. defined var => var_list%first if (present (type)) then do while (associated (var)) if (var%type == type) then if (var%name == name) then if (ignore_undef .or. var%is_defined) return end if end if var => var%next end do else do while (associated (var)) if (var%name == name) then if (ignore_undef .or. var%is_defined) return end if var => var%next end do end if search_next = associated (var_list%next) if (present (follow_link)) & search_next = search_next .and. follow_link if (search_next) & var => var_list_get_var_ptr & (var_list%next, name, type, defined=defined) end function var_list_get_var_ptr @ %def var_list_get_var_ptr @ Return the variable type <>= procedure :: get_type => var_list_get_type <>= function var_list_get_type (var_list, name, follow_link) result (type) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name logical, intent(in), optional :: follow_link integer :: type type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, follow_link=follow_link) if (associated (var)) then type = var%type else type = V_NONE end if end function var_list_get_type @ %def var_list_get_type @ Return true if the variable exists in the current list. <>= procedure :: contains => var_list_exists <>= function var_list_exists (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) lval = associated (var) end function var_list_exists @ %def var_list_exists @ Return true if the variable is declared as intrinsic. (This is not a property of the abstract [[vars_t]] type, and therefore the method is not inherited.) <>= procedure :: is_intrinsic => var_list_is_intrinsic <>= function var_list_is_intrinsic (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then lval = var%is_intrinsic else lval = .false. end if end function var_list_is_intrinsic @ %def var_list_is_intrinsic @ Return true if the value is known. <>= procedure :: is_known => var_list_is_known <>= function var_list_is_known (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then lval = var%is_known else lval = .false. end if end function var_list_is_known @ %def var_list_is_known @ Return true if the value is locked. (This is not a property of the abstract [[vars_t]] type, and therefore the method is not inherited.) <>= procedure :: is_locked => var_list_is_locked <>= function var_list_is_locked (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then lval = var_entry_is_locked (var) else lval = .false. end if end function var_list_is_locked @ %def var_list_is_locked @ Return several properties at once. <>= procedure :: get_var_properties => var_list_get_var_properties <>= subroutine var_list_get_var_properties (vars, name, req_type, follow_link, & type, is_defined, is_known, is_locked) class(var_list_t), intent(in) :: vars type(string_t), intent(in) :: name integer, intent(in), optional :: req_type logical, intent(in), optional :: follow_link integer, intent(out), optional :: type logical, intent(out), optional :: is_defined, is_known, is_locked type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, type=req_type, follow_link=follow_link) if (associated (var)) then if (present (type)) type = var_entry_get_type (var) if (present (is_defined)) is_defined = var_entry_is_defined (var) if (present (is_known)) is_known = var_entry_is_known (var) if (present (is_locked)) is_locked = var_entry_is_locked (var) else if (present (type)) type = V_NONE if (present (is_defined)) is_defined = .false. if (present (is_known)) is_known = .false. if (present (is_locked)) is_locked = .false. end if end subroutine var_list_get_var_properties @ %def var_list_get_var_properties @ Return the value, assuming that the type is correct. We consider only variable entries that have been [[defined]]. For convenience, allow both variable and fixed-length (literal) strings. <>= procedure :: get_lval => var_list_get_lval procedure :: get_ival => var_list_get_ival procedure :: get_rval => var_list_get_rval procedure :: get_cval => var_list_get_cval procedure :: get_pval => var_list_get_pval procedure :: get_aval => var_list_get_aval procedure :: get_sval => var_list_get_sval <>= function var_list_get_lval (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_LOG, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then lval = var%lval else lval = .false. end if else lval = .false. end if end function var_list_get_lval function var_list_get_ival (vars, name, follow_link) result (ival) integer :: ival type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_INT, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then ival = var%ival else ival = 0 end if else ival = 0 end if end function var_list_get_ival function var_list_get_rval (vars, name, follow_link) result (rval) real(default) :: rval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_REAL, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then rval = var%rval else rval = 0 end if else rval = 0 end if end function var_list_get_rval function var_list_get_cval (vars, name, follow_link) result (cval) complex(default) :: cval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_CMPLX, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then cval = var%cval else cval = 0 end if else cval = 0 end if end function var_list_get_cval function var_list_get_aval (vars, name, follow_link) result (aval) type(pdg_array_t) :: aval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_PDG, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then aval = var%aval end if end if end function var_list_get_aval function var_list_get_pval (vars, name, follow_link) result (pval) type(subevt_t) :: pval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_SEV, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then pval = var%pval end if end if end function var_list_get_pval function var_list_get_sval (vars, name, follow_link) result (sval) type(string_t) :: sval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_STR, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then sval = var%sval else sval = "" end if else sval = "" end if end function var_list_get_sval @ %def var_list_get_lval @ %def var_list_get_ival @ %def var_list_get_rval @ %def var_list_get_cval @ %def var_list_get_pval @ %def var_list_get_aval @ %def var_list_get_sval @ Check for a valid value, given a pointer. Issue error messages if invalid. <>= function var_has_value (var) result (valid) logical :: valid type(var_entry_t), pointer :: var if (associated (var)) then if (var%is_known) then valid = .true. else call msg_error ("The value of variable '" // char (var%name) & // "' is unknown but must be known at this point.") valid = .false. end if else call msg_error ("Variable '" // char (var%name) & // "' is undefined but must have a known value at this point.") valid = .false. end if end function var_has_value @ %def var_has_value @ Return pointers instead of values, including a pointer to the [[known]] entry. <>= procedure :: get_lptr => var_list_get_lptr procedure :: get_iptr => var_list_get_iptr procedure :: get_rptr => var_list_get_rptr procedure :: get_cptr => var_list_get_cptr procedure :: get_aptr => var_list_get_aptr procedure :: get_pptr => var_list_get_pptr procedure :: get_sptr => var_list_get_sptr <>= subroutine var_list_get_lptr (var_list, name, lptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name logical, pointer, intent(out) :: lptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_LOG) if (associated (var)) then lptr => var_entry_get_lval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else lptr => null () if (present (known)) known => null () end if end subroutine var_list_get_lptr subroutine var_list_get_iptr (var_list, name, iptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name integer, pointer, intent(out) :: iptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_INT) if (associated (var)) then iptr => var_entry_get_ival_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else iptr => null () if (present (known)) known => null () end if end subroutine var_list_get_iptr subroutine var_list_get_rptr (var_list, name, rptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name real(default), pointer, intent(out) :: rptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_REAL) if (associated (var)) then rptr => var_entry_get_rval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else rptr => null () if (present (known)) known => null () end if end subroutine var_list_get_rptr subroutine var_list_get_cptr (var_list, name, cptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name complex(default), pointer, intent(out) :: cptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_CMPLX) if (associated (var)) then cptr => var_entry_get_cval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else cptr => null () if (present (known)) known => null () end if end subroutine var_list_get_cptr subroutine var_list_get_aptr (var_list, name, aptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), pointer, intent(out) :: aptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_PDG) if (associated (var)) then aptr => var_entry_get_aval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else aptr => null () if (present (known)) known => null () end if end subroutine var_list_get_aptr subroutine var_list_get_pptr (var_list, name, pptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(subevt_t), pointer, intent(out) :: pptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_SEV) if (associated (var)) then pptr => var_entry_get_pval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else pptr => null () if (present (known)) known => null () end if end subroutine var_list_get_pptr subroutine var_list_get_sptr (var_list, name, sptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(string_t), pointer, intent(out) :: sptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_STR) if (associated (var)) then sptr => var_entry_get_sval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else sptr => null () if (present (known)) known => null () end if end subroutine var_list_get_sptr @ %def var_list_get_lptr @ %def var_list_get_iptr @ %def var_list_get_rptr @ %def var_list_get_cptr @ %def var_list_get_aptr @ %def var_list_get_pptr @ %def var_list_get_sptr @ This bunch of methods handles the procedure-pointer cases. <>= procedure :: get_obs1_iptr => var_list_get_obs1_iptr procedure :: get_obs2_iptr => var_list_get_obs2_iptr procedure :: get_obsev_iptr => var_list_get_obsev_iptr procedure :: get_obs1_rptr => var_list_get_obs1_rptr procedure :: get_obs2_rptr => var_list_get_obs2_rptr procedure :: get_obsev_rptr => var_list_get_obsev_rptr <>= subroutine var_list_get_obs1_iptr (var_list, name, obs1_iptr, p1) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_int), pointer, intent(out) :: obs1_iptr type(prt_t), pointer, intent(out) :: p1 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS1_INT) if (associated (var)) then call var_entry_assign_obs1_int_ptr (obs1_iptr, var) p1 => var_entry_get_prt1_ptr (var) else obs1_iptr => null () p1 => null () end if end subroutine var_list_get_obs1_iptr subroutine var_list_get_obs2_iptr (var_list, name, obs2_iptr, p1, p2) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_int), pointer, intent(out) :: obs2_iptr type(prt_t), pointer, intent(out) :: p1, p2 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS2_INT) if (associated (var)) then call var_entry_assign_obs2_int_ptr (obs2_iptr, var) p1 => var_entry_get_prt1_ptr (var) p2 => var_entry_get_prt2_ptr (var) else obs2_iptr => null () p1 => null () p2 => null () end if end subroutine var_list_get_obs2_iptr subroutine var_list_get_obsev_iptr (var_list, name, obsev_iptr, pval) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_int), pointer, intent(out) :: obsev_iptr type(subevt_t), pointer, intent(out) :: pval type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBSEV_INT) if (associated (var)) then call var_entry_assign_obsev_int_ptr (obsev_iptr, var) pval => var_entry_get_pval_ptr (var) else obsev_iptr => null () pval => null () end if end subroutine var_list_get_obsev_iptr subroutine var_list_get_obs1_rptr (var_list, name, obs1_rptr, p1) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_real), pointer, intent(out) :: obs1_rptr type(prt_t), pointer, intent(out) :: p1 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS1_REAL) if (associated (var)) then call var_entry_assign_obs1_real_ptr (obs1_rptr, var) p1 => var_entry_get_prt1_ptr (var) else obs1_rptr => null () p1 => null () end if end subroutine var_list_get_obs1_rptr subroutine var_list_get_obs2_rptr (var_list, name, obs2_rptr, p1, p2) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_real), pointer, intent(out) :: obs2_rptr type(prt_t), pointer, intent(out) :: p1, p2 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS2_REAL) if (associated (var)) then call var_entry_assign_obs2_real_ptr (obs2_rptr, var) p1 => var_entry_get_prt1_ptr (var) p2 => var_entry_get_prt2_ptr (var) else obs2_rptr => null () p1 => null () p2 => null () end if end subroutine var_list_get_obs2_rptr subroutine var_list_get_obsev_rptr (var_list, name, obsev_rptr, pval) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_real), pointer, intent(out) :: obsev_rptr type(subevt_t), pointer, intent(out) :: pval type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBSEV_REAL) if (associated (var)) then call var_entry_assign_obsev_real_ptr (obsev_rptr, var) pval => var_entry_get_pval_ptr (var) else obsev_rptr => null () pval => null () end if end subroutine var_list_get_obsev_rptr @ %def var_list_get_obs1_iptr @ %def var_list_get_obs2_iptr @ %def var_list_get_obsev_iptr @ %def var_list_get_obs1_rptr @ %def var_list_get_obs2_rptr @ %def var_list_get_obsev_rptr @ \subsection{Process Result Variables} These variables are associated to process (integration) runs and their results. Their names contain brackets (so they look like function evaluations), therefore we need to special-case them. <>= public :: var_list_set_procvar_int public :: var_list_set_procvar_real <>= subroutine var_list_set_procvar_int (var_list, proc_id, name, ival) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id type(string_t), intent(in) :: name integer, intent(in), optional :: ival type(string_t) :: var_name type(var_entry_t), pointer :: var var_name = name // "(" // proc_id // ")" var => var_list_get_var_ptr (var_list, var_name) if (.not. associated (var)) then call var_list%append_int (var_name, ival, intrinsic=.true.) else if (present (ival)) then call var_list%set_int (var_name, ival, is_known=.true.) end if end subroutine var_list_set_procvar_int subroutine var_list_set_procvar_real (var_list, proc_id, name, rval) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id type(string_t), intent(in) :: name real(default), intent(in), optional :: rval type(string_t) :: var_name type(var_entry_t), pointer :: var var_name = name // "(" // proc_id // ")" var => var_list_get_var_ptr (var_list, var_name) if (.not. associated (var)) then call var_list%append_real (var_name, rval, intrinsic=.true.) else if (present (rval)) then call var_list%set_real (var_name, rval, is_known=.true.) end if end subroutine var_list_set_procvar_real @ %def var_list_set_procvar_int @ %def var_list_set_procvar_real @ \subsection{Observable initialization} Observables are formally treated as variables, which however are evaluated each time the observable is used. The arguments (pointers) to evaluate and the function are part of the variable-list entry. <>= public :: var_list_append_obs1_iptr public :: var_list_append_obs2_iptr public :: var_list_append_obs1_rptr public :: var_list_append_obs2_rptr public :: var_list_append_obsev_iptr public :: var_list_append_obsev_rptr <>= subroutine var_list_append_obs1_iptr (var_list, name, obs1_iptr, p1) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_int) :: obs1_iptr type(prt_t), intent(in), target :: p1 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS1_INT, p1) var%obs1_int => obs1_iptr call var_list_append (var_list, var) end subroutine var_list_append_obs1_iptr subroutine var_list_append_obs2_iptr (var_list, name, obs2_iptr, p1, p2) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_int) :: obs2_iptr type(prt_t), intent(in), target :: p1, p2 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS2_INT, p1, p2) var%obs2_int => obs2_iptr call var_list_append (var_list, var) end subroutine var_list_append_obs2_iptr subroutine var_list_append_obsev_iptr (var_list, name, obsev_iptr, sev) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_int) :: obsev_iptr type(subevt_t), intent(in), target :: sev type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs_sev (var, name, V_OBSEV_INT, sev) var%obsev_int => obsev_iptr call var_list_append (var_list, var) end subroutine var_list_append_obsev_iptr subroutine var_list_append_obs1_rptr (var_list, name, obs1_rptr, p1) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_real) :: obs1_rptr type(prt_t), intent(in), target :: p1 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS1_REAL, p1) var%obs1_real => obs1_rptr call var_list_append (var_list, var) end subroutine var_list_append_obs1_rptr subroutine var_list_append_obs2_rptr (var_list, name, obs2_rptr, p1, p2) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_real) :: obs2_rptr type(prt_t), intent(in), target :: p1, p2 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS2_REAL, p1, p2) var%obs2_real => obs2_rptr call var_list_append (var_list, var) end subroutine var_list_append_obs2_rptr subroutine var_list_append_obsev_rptr (var_list, name, obsev_rptr, sev) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_real) :: obsev_rptr type(subevt_t), intent(in), target :: sev type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs_sev (var, name, V_OBSEV_REAL, sev) var%obsev_real => obsev_rptr call var_list_append (var_list, var) end subroutine var_list_append_obsev_rptr @ %def var_list_append_obs1_iptr @ %def var_list_append_obs2_iptr @ %def var_list_append_obs1_rptr @ %def var_list_append_obs2_rptr @ User observables: no pointer needs to be stored. <>= public :: var_list_append_uobs_int public :: var_list_append_uobs_real <>= subroutine var_list_append_uobs_int (var_list, name, p1, p2) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(prt_t), intent(in), target :: p1 type(prt_t), intent(in), target, optional :: p2 type(var_entry_t), pointer :: var allocate (var) if (present (p2)) then call var_entry_init_obs (var, name, V_UOBS2_INT, p1, p2) else call var_entry_init_obs (var, name, V_UOBS1_INT, p1) end if call var_list_append (var_list, var) end subroutine var_list_append_uobs_int subroutine var_list_append_uobs_real (var_list, name, p1, p2) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(prt_t), intent(in), target :: p1 type(prt_t), intent(in), target, optional :: p2 type(var_entry_t), pointer :: var allocate (var) if (present (p2)) then call var_entry_init_obs (var, name, V_UOBS2_REAL, p1, p2) else call var_entry_init_obs (var, name, V_UOBS1_REAL, p1) end if call var_list_append (var_list, var) end subroutine var_list_append_uobs_real @ %def var_list_append_uobs_int @ %def var_list_append_uobs_real @ \subsection{API for variable lists} Set a new value. If the variable holds a pointer, this pointer is followed, e.g., a model parameter is actually set. If [[ignore]] is set, do nothing if the variable does not exist. If [[verbose]] is set, echo the new value. Clear a variable (all variables), i.e., undefine the value. <>= procedure :: unset => var_list_clear <>= subroutine var_list_clear (vars, name, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_clear (var) end if end subroutine var_list_clear @ %def var_list_clear @ Setting the value, concise specific versions (implementing deferred TBP): <>= procedure :: set_ival => var_list_set_ival procedure :: set_rval => var_list_set_rval procedure :: set_cval => var_list_set_cval procedure :: set_lval => var_list_set_lval procedure :: set_sval => var_list_set_sval <>= subroutine var_list_set_ival (vars, name, ival, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name integer, intent(in) :: ival logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_int (var, ival, is_known=.true.) end if end subroutine var_list_set_ival subroutine var_list_set_rval (vars, name, rval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_real (var, rval, is_known=.true.) end if end subroutine var_list_set_rval subroutine var_list_set_cval (vars, name, cval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name complex(default), intent(in) :: cval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_cmplx (var, cval, is_known=.true.) end if end subroutine var_list_set_cval subroutine var_list_set_lval (vars, name, lval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name logical, intent(in) :: lval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_log (var, lval, is_known=.true.) end if end subroutine var_list_set_lval subroutine var_list_set_sval (vars, name, sval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name type(string_t), intent(in) :: sval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_string (var, sval, is_known=.true.) end if end subroutine var_list_set_sval @ %def var_list_set_ival @ %def var_list_set_rval @ %def var_list_set_cval @ %def var_list_set_lval @ %def var_list_set_sval @ Setting the value, verbose specific versions (as subroutines): <>= procedure :: set_log => var_list_set_log procedure :: set_int => var_list_set_int procedure :: set_real => var_list_set_real procedure :: set_cmplx => var_list_set_cmplx procedure :: set_subevt => var_list_set_subevt procedure :: set_pdg_array => var_list_set_pdg_array procedure :: set_string => var_list_set_string <>= subroutine var_list_set_log & (var_list, name, lval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name logical, intent(in) :: lval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_LOG) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_LOG) call var_entry_set_log (var, lval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_log subroutine var_list_set_int & (var_list, name, ival, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name integer, intent(in) :: ival logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_INT) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_INT) call var_entry_set_int (var, ival, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_int subroutine var_list_set_real & (var_list, name, rval, is_known, ignore, force, & verbose, model_name, pacified) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose, pacified type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_REAL) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_REAL) call var_entry_set_real & (var, rval, is_known, verbose, model_name, pacified) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_real subroutine var_list_set_cmplx & (var_list, name, cval, is_known, ignore, force, & verbose, model_name, pacified) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name complex(default), intent(in) :: cval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose, pacified type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_CMPLX) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_CMPLX) call var_entry_set_cmplx & (var, cval, is_known, verbose, model_name, pacified) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_cmplx subroutine var_list_set_pdg_array & (var_list, name, aval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in) :: aval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_PDG) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_PDG) call var_entry_set_pdg_array & (var, aval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_pdg_array subroutine var_list_set_subevt & (var_list, name, pval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in) :: pval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_SEV) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_SEV) call var_entry_set_subevt & (var, pval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_subevt subroutine var_list_set_string & (var_list, name, sval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(string_t), intent(in) :: sval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_STR) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_STR) call var_entry_set_string & (var, sval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_string subroutine var_mismatch_error (name) type(string_t), intent(in) :: name call msg_fatal ("Type mismatch for variable '" // char (name) // "'") end subroutine var_mismatch_error subroutine var_locked_error (name) type(string_t), intent(in) :: name call msg_error ("Variable '" // char (name) // "' is not user-definable") end subroutine var_locked_error subroutine var_missing_error (name, ignore) type(string_t), intent(in) :: name logical, intent(in), optional :: ignore logical :: error if (present (ignore)) then error = .not. ignore else error = .true. end if if (error) then call msg_fatal ("Variable '" // char (name) // "' has not been declared") end if end subroutine var_missing_error @ %def var_list_set_log @ %def var_list_set_int @ %def var_list_set_real @ %def var_list_set_cmplx @ %def var_list_set_subevt @ %def var_list_set_pdg_array @ %def var_list_set_string @ %def var_mismatch_error @ %def var_missing_error @ Import values for the current variable list from another list. <>= public :: var_list_import <>= procedure :: import => var_list_import <>= subroutine var_list_import (var_list, src_list) class(var_list_t), intent(inout) :: var_list type(var_list_t), intent(in) :: src_list type(var_entry_t), pointer :: var, src var => var_list%first do while (associated (var)) src => var_list_get_var_ptr (src_list, var%name) if (associated (src)) then call var_entry_copy_value (var, src) end if var => var%next end do end subroutine var_list_import @ %def var_list_import @ Mark all entries in the current variable list as undefined. This is done when a local variable list is discarded. If the local list is used again (by a loop), the entries will be re-initialized. <>= public :: var_list_undefine <>= procedure :: undefine => var_list_undefine <>= recursive subroutine var_list_undefine (var_list, follow_link) class(var_list_t), intent(inout) :: var_list logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link var => var_list%first do while (associated (var)) call var_entry_undefine (var) var => var%next end do if (rec .and. associated (var_list%next)) then call var_list_undefine (var_list%next, follow_link=follow_link) end if end subroutine var_list_undefine @ %def var_list_undefine @ Make a deep copy of a variable list. <>= public :: var_list_init_snapshot <>= procedure :: init_snapshot => var_list_init_snapshot <>= recursive subroutine var_list_init_snapshot (var_list, vars_in, follow_link) class(var_list_t), intent(out) :: var_list type(var_list_t), intent(in) :: vars_in logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var, var_in type(var_list_t), pointer :: var_list_next logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link var_in => vars_in%first do while (associated (var_in)) allocate (var) call var_entry_init_copy (var, var_in) call var_entry_copy_value (var, var_in) call var_list_append (var_list, var) var_in => var_in%next end do if (rec .and. associated (vars_in%next)) then allocate (var_list_next) call var_list_init_snapshot (var_list_next, vars_in%next) call var_list%link (var_list_next) end if end subroutine var_list_init_snapshot @ %def var_list_init_snapshot @ Check if a user variable can be set. The [[new]] flag is set if the user variable has an explicit declaration. If an error occurs, return [[V_NONE]] as variable type. Also determine the actual type of generic numerical variables, which enter the procedure with type [[V_NONE]]. <>= public :: var_list_check_user_var <>= procedure :: check_user_var => var_list_check_user_var <>= subroutine var_list_check_user_var (var_list, name, type, new) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(inout) :: type logical, intent(in) :: new type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name) if (associated (var)) then if (type == V_NONE) then type = var_entry_get_type (var) end if if (var_entry_is_locked (var)) then call msg_fatal ("Variable '" // char (name) & // "' is not user-definable") type = V_NONE return else if (new) then if (var_entry_is_intrinsic (var)) then call msg_fatal ("Intrinsic variable '" & // char (name) // "' redeclared") type = V_NONE return end if if (var_entry_get_type (var) /= type) then call msg_fatal ("Variable '" // char (name) // "' " & // "redeclared with different type") type = V_NONE return end if end if end if end subroutine var_list_check_user_var @ %def var_list_check_user_var @ \subsection{Default values for global var list} <>= procedure :: init_defaults => var_list_init_defaults <>= subroutine var_list_init_defaults (var_list, seed, paths) class(var_list_t), intent(out) :: var_list integer, intent(in) :: seed type(paths_t), intent(in), optional :: paths call var_list%set_beams_defaults (paths) call var_list%set_core_defaults (seed) call var_list%set_integration_defaults () call var_list%set_phase_space_defaults () call var_list%set_gamelan_defaults () call var_list%set_clustering_defaults () call var_list%set_isolation_recomb_defaults () call var_list%set_eio_defaults () call var_list%set_shower_defaults () call var_list%set_hadronization_defaults () call var_list%set_tauola_defaults () call var_list%set_mlm_matching_defaults () call var_list%set_powheg_matching_defaults () call var_list%append_log (var_str ("?ckkw_matching"), .false., & intrinsic=.true., description=var_str ('Master flag that switches ' // & 'on the CKKW(-L) (LO) matching between hard scattering matrix ' // & 'elements and QCD parton showers. Note that this is not yet ' // & '(completely) implemented in \whizard. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})')) call var_list%set_openmp_defaults () call var_list%set_mpi_defaults () call var_list%set_nlo_defaults () end subroutine var_list_init_defaults @ %def var_list_init_defaults @ <>= procedure :: set_beams_defaults => var_list_set_beams_defaults <>= subroutine var_list_set_beams_defaults (var_list, paths) type(paths_t), intent(in), optional :: paths class(var_list_t), intent(inout) :: var_list call var_list%append_real (var_str ("sqrts"), & intrinsic=.true., & description=var_str ('Real variable in order to set the center-of-mass ' // & 'energy for the collisions (collider energy $\sqrt{s}$, not ' // & 'hard interaction energy $\sqrt{\hat{s}}$): \ttt{sqrts = {\em ' // & '} [ {\em } ]}. The physical unit can be one ' // & 'of the following \ttt{eV}, \ttt{keV}, \ttt{MeV}, \ttt{GeV}, ' // & 'and \ttt{TeV}. If absent, \whizard\ takes \ttt{GeV} as its ' // & 'standard unit. Note that this variable is absolutely mandatory ' // & 'for integration and simulation of scattering processes.')) call var_list%append_real (var_str ("luminosity"), 0._default, & intrinsic=.true., & description=var_str ('This specifier \ttt{luminosity = {\em ' // & '}} sets the integrated luminosity (in inverse femtobarns, ' // & 'fb${}^{-1}$) for the event generation of the processes in the ' // & '\sindarin\ input files. Note that WHIZARD itself chooses the ' // & 'number from the \ttt{luminosity} or from the \ttt{n\_events} ' // & 'specifier, whichever would give the larger number of events. ' // & 'As this depends on the cross section under consideration, it ' // & 'might be different for different processes in the process list. ' // & '(cf. \ttt{n\_events}, \ttt{\$sample}, \ttt{sample\_format}, \ttt{?unweighted})')) call var_list%append_log (var_str ("?sf_trace"), .false., & intrinsic=.true., & description=var_str ('Debug flag that writes out detailed information ' // & 'about the structure function setup into the file \ttt{{\em ' // & '}\_sftrace.dat}. This file name can be changed ' // & 'with ($\to$) \ttt{\$sf\_trace\_file}.')) call var_list%append_string (var_str ("$sf_trace_file"), var_str (""), & intrinsic=.true., & description=var_str ('\ttt{\$sf\_trace\_file = "{\em }"} ' // & 'allows to change the detailed structure function information ' // & 'switched on by the debug flag ($\to$) \ttt{?sf\_trace} into ' // & 'a different file \ttt{{\em }} than the default ' // & '\ttt{{\em }\_sftrace.dat}.')) call var_list%append_log (var_str ("?sf_allow_s_mapping"), .true., & intrinsic=.true., & description=var_str ('Flag that determines whether special mappings ' // & 'for processes with structure functions and $s$-channel resonances ' // & 'are applied, e.g. Drell-Yan at hadron colliders, or $Z$ production ' // & 'at linear colliders with beamstrahlung and ISR.')) if (present (paths)) then call var_list%append_string (var_str ("$lhapdf_dir"), paths%lhapdfdir, & intrinsic=.true., & description=var_str ('String variable that tells the path ' // & 'where the \lhapdf\ library and PDF sets can be found. When ' // & 'the library has been correctly recognized during configuration, ' // & 'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // & '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // & '\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})')) else call var_list%append_string (var_str ("$lhapdf_dir"), var_str(""), & intrinsic=.true., & description=var_str ('String variable that tells the path ' // & 'where the \lhapdf\ library and PDF sets can be found. When ' // & 'the library has been correctly recognized during configuration, ' // & 'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // & '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // & '\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})')) end if call var_list%append_string (var_str ("$lhapdf_file"), var_str (""), & intrinsic=.true., & description=var_str ('This string variable \ttt{\$lhapdf\_file ' // & '= "{\em }"} allows to specify the PDF set \ttt{{\em ' // & '}} from the external \lhapdf\ library. It must match ' // & 'the exact name of the PDF set from the \lhapdf\ library. The ' // & 'default is empty, and the default set from \lhapdf\ is taken. ' // & 'Only one argument is possible, the PDF set must be identical ' // & 'for both beams, unless there are fundamentally different beam ' // & 'particles like proton and photon. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // & '\ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_photon\_scheme}, ' // & '\ttt{lhapdf\_member})')) call var_list%append_string (var_str ("$lhapdf_photon_file"), var_str (""), & intrinsic=.true., & description=var_str ('String variable \ttt{\$lhapdf\_photon\_file ' // & '= "{\em }"} analagous to ($\to$) \ttt{\$lhapdf\_file} ' // & 'for photon PDF structure functions from the external \lhapdf\ ' // & 'library. The name must exactly match the one of the set from ' // & '\lhapdf. (cf. \ttt{beams}, \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // & '\ttt{\$lhapdf\_file}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member}, ' // & '\ttt{lhapdf\_photon\_scheme})')) call var_list%append_int (var_str ("lhapdf_member"), 0, & intrinsic=.true., & description=var_str ('Integer variable that specifies the number ' // & 'of the corresponding PDF set chosen via the command ($\to$) ' // & '\ttt{\$lhapdf\_file} or ($\to$) \ttt{\$lhapdf\_photon\_file} ' // & 'from the external \lhapdf\ library. E.g. error PDF sets can ' // & 'be chosen by this. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // & '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // & '\ttt{lhapdf\_photon\_scheme})')) call var_list%append_int (var_str ("lhapdf_photon_scheme"), 0, & intrinsic=.true., & description=var_str ('Integer parameter that controls the different ' // & 'available schemes for photon PDFs inside the external \lhapdf\ ' // & 'library. For more details see the \lhapdf\ manual. (cf. also ' // & '\ttt{lhapdf}, \ttt{\$lhapdf\_dir}, \ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, ' // & '\ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member})')) call var_list%append_string (var_str ("$pdf_builtin_set"), var_str ("CTEQ6L"), & intrinsic=.true., & description=var_str ("For \whizard's internal PDF structure functions " // & 'for hadron colliders, this string variable allows to set the ' // & 'particular PDF set. (cf. also \ttt{pdf\_builtin}, \ttt{pdf\_builtin\_photon})')) call var_list%append_log (var_str ("?hoppet_b_matching"), .false., & intrinsic=.true., & description=var_str ('Flag that switches on the matching between ' // & '4- and 5-flavor schemes for hadron collider $b$-parton initiated ' // & 'processes. Works either with builtin PDFs or with the external ' // & '\lhapdf\ interface. Needs the external \ttt{HOPPET} library ' // & 'to be linked. (cf. \ttt{beams}, \ttt{pdf\_builtin}, \ttt{lhapdf})')) call var_list%append_real (var_str ("isr_alpha"), 0._default, & intrinsic=.true., & description=var_str ('For lepton collider initial-state QED ' // & 'radiation (ISR), this real parameter sets the value of $\alpha_{em}$ ' // & 'used in the structure function. If not set, it is taken from ' // & 'the parameter set of the physics model in use (cf. also \ttt{isr}, ' // & '\ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // & '\ttt{?isr\_keep\_energy})')) call var_list%append_real (var_str ("isr_q_max"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set the ' // & 'scale of the initial-state QED radiation (ISR) structure function. ' // & 'If not set, it is taken internally to be $\sqrt{s}$. (cf. ' // & 'also \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // & '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})')) call var_list%append_real (var_str ("isr_mass"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set by hand ' // & 'the mass of the incoming particle for lepton collider initial-state ' // & 'QED radiation (ISR). If not set, the mass for the initial beam ' // & 'particle is taken from the model in use. (cf. also \ttt{isr}, ' // & '\ttt{isr\_q\_max}, \ttt{isr\_alpha}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // & '\ttt{?isr\_keep\_energy})')) call var_list%append_int (var_str ("isr_order"), 3, & intrinsic=.true., & description=var_str ('For lepton collider initial-state QED ' // & 'radiation (ISR), this integer parameter allows to set the order ' // & 'up to which hard-collinear radiation is taken into account. ' // & 'Default is the highest available, namely third order. (cf. ' // & 'also \ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_alpha}, ' // & '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})')) call var_list%append_log (var_str ("?isr_recoil"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // & '$p_T$-kick for the lepton collider initial-state QED radiation ' // & '(ISR). (cf. also \ttt{isr}, \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, ' // & '\ttt{isr\_order}, \ttt{isr\_q\_max})')) call var_list%append_log (var_str ("?isr_keep_energy"), .false., & intrinsic=.true., & description=var_str ('As the splitting kinematics for the ISR ' // & 'structure function violates Lorentz invariance when the recoil ' // & 'is switched on, this flag forces energy conservation when set ' // & 'to true, otherwise violating energy conservation. (cf. also ' // & '\ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // & '\ttt{?isr\_recoil}, \ttt{?isr\_alpha})')) call var_list%append_log (var_str ("?isr_handler"), .false., & intrinsic=.true., & description=var_str ('Activate ISR ' // & 'handler for event generation (no effect on integration). ' // & 'Requires \ttt{isr\_recoil = false}')) call var_list%append_string (var_str ("$isr_handler_mode"), & var_str ("trivial"), & intrinsic=.true., & description=var_str ('Operation mode for the ISR ' // & 'event handler. Allowed values: \ttt{trivial} (no effect), ' // & '\ttt{recoil} (recoil kinematics with two photons)')) call var_list%append_log (var_str ("?isr_handler_keep_mass"), .true., & intrinsic=.true., & description=var_str ('If \ttt{true} (default), force the incoming ' // & 'partons of the hard process (after radiation) on their mass ' // & 'shell. Otherwise, insert massless on-shell momenta. This ' // & 'applies only for event generation (no effect on integration, ' // & 'cf.\ also \ttt{?isr\_handler})')) call var_list%append_string (var_str ("$epa_mode"), & var_str ("default"), intrinsic=.true., & description=var_str ('For the equivalent photon approximation ' // & '(EPA), this string variable defines the mode, i.e. the explicit ' // & 'formula for the EPA distribution. For more details cf. the manual. ' // & 'Possible are \ttt{default} (\ttt{Budnev\_617}), \ttt{Budnev\_616e}, ' // & '\ttt{log\_power}, \ttt{log\_simple}, and \ttt{log}. ' // & '(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, ' // & '\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_alpha"), 0._default, & intrinsic=.true., & description=var_str ('For the equivalent photon approximation ' // & '(EPA), this real parameter sets the value of $\alpha_{em}$ ' // & 'used in the structure function. If not set, it is taken from ' // & 'the parameter set of the physics model in use (cf. also \ttt{epa}, ' // & '\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, \ttt{epa\_q\_min}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_x_min"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the lower cutoff ' // & 'for the energy fraction in the splitting for the equivalent-photon ' // & 'approximation (EPA). This parameter has to be set by the user ' // & 'to a non-zero value smaller than one. (cf. also \ttt{epa}, ' // & '\ttt{epa\_e\_max}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_q_min"), 0._default, & intrinsic=.true., & description=var_str ('In the equivalent-photon approximation ' // & '(EPA), this real parameters sets the minimal value for the ' // & 'transferred momentum. Either this parameter or the mass of ' // & 'the beam particle has to be non-zero. (cf. also \ttt{epa}, ' // & '\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_max}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_q_max"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set the ' // & 'upper energy cutoff for the equivalent-photon approximation ' // & '(EPA). If not set, \whizard\ simply takes the collider energy, ' // & '$\sqrt{s}$. (cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, ' // & '\ttt{epa\_alpha}, \ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_keep\_energy}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_mass"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set by hand ' // & 'the mass of the incoming particle for the equivalent-photon ' // & 'approximation (EPA). If not set, the mass for the initial beam ' // & 'particle is taken from the model in use. (cf. also \ttt{epa}, ' // & '\ttt{epa\_x\_min}, \ttt{epa\_e\_max}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}. ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_log (var_str ("?epa_recoil"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // & '$p_T$-kick for the equivalent-photon approximation (EPA). ' // & '(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // & '\ttt{epa\_e\_max}, \ttt{epa\_q\_min}, \ttt{?epa\_keep\_energy}, ' // & '\ttt{\$epa\_mode}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_log (var_str ("?epa_keep_energy"), .false., & intrinsic=.true., & description=var_str ('As the splitting kinematics for the EPA ' // & 'structure function violates Lorentz invariance when the recoil ' // & 'is switched on, this flag forces energy conservation when set ' // & 'to true, otherwise violating energy conservation. (cf. also ' // & '\ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // & '\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_log (var_str ("?epa_handler"), .false., & intrinsic=.true., & description=var_str ('Activate EPA ' // & 'handler for event generation (no effect on integration). ' // & 'Requires \ttt{epa\_recoil = false}')) call var_list%append_string (var_str ("$epa_handler_mode"), & var_str ("trivial"), & intrinsic=.true., & description=var_str ('Operation mode for the EPA ' // & 'event handler. Allowed values: \ttt{trivial} (no effect), ' // & '\ttt{recoil} (recoil kinematics with two beams)')) call var_list%append_real (var_str ("ewa_x_min"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the lower cutoff ' // & 'for the energy fraction in the splitting for the equivalent ' // & '$W$ approximation (EWA). This parameter has to be set by the ' // & 'user to a non-zero value smaller than one. (cf. also \ttt{ewa}, ' // & '\ttt{ewa\_pt\_max}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // & '\ttt{?ewa\_recoil})')) call var_list%append_real (var_str ("ewa_pt_max"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set the ' // & 'upper $p_T$ cutoff for the equivalent $W$ approximation (EWA). ' // & 'If not set, \whizard\ simply takes the collider energy, $\sqrt{s}$. ' // & '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // & '\ttt{?ewa\_recoil})')) call var_list%append_real (var_str ("ewa_mass"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set by hand ' // & 'the mass of the incoming particle for the equivalent $W$ approximation ' // & '(EWA). If not set, the mass for the initial beam particle is ' // & 'taken from the model in use. (cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, ' // & '\ttt{ewa\_pt\_max}, \ttt{?ewa\_keep\_energy}, \ttt{?ewa\_recoil})')) call var_list%append_log (var_str ("?ewa_recoil"), .false., & intrinsic=.true., & description=var_str ('For the equivalent $W$ approximation (EWA), ' // & 'this flag switches on recoil, i.e. non-collinear splitting. ' // & '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max}, ' // & '\ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy})')) call var_list%append_log (var_str ("?ewa_keep_energy"), .false., & intrinsic=.true., & description=var_str ('As the splitting kinematics for the equivalent ' // & '$W$ approximation (EWA) violates Lorentz invariance when the ' // & 'recoil is switched on, this flag forces energy conservation ' // & 'when set to true, otherwise violating energy conservation. ' // & '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max}, ' // & '\ttt{ewa\_mass}, \ttt{?ewa\_recoil})')) call var_list%append_log (var_str ("?circe1_photon1"), .false., & intrinsic=.true., & description=var_str ('Flag to tell \whizard\ to use the photon ' // & 'of the \circeone\ beamstrahlung structure function as initiator ' // & 'for the hard scattering process in the first beam. (cf. also ' // & '\ttt{circe1}, \ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_photon2"), .false., & intrinsic=.true., & description=var_str ('Flag to tell \whizard\ to use the photon ' // & 'of the \circeone\ beamstrahlung structure function as initiator ' // & 'for the hard scattering process in the second beam. (cf. also ' // & '\ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{circe1\_sqrts}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // & '\newline\ttt{?circe1\_with\_radiation})')) call var_list%append_real (var_str ("circe1_sqrts"), & intrinsic=.true., & description=var_str ('Real parameter that allows to set the ' // & 'value of the collider energy for the lepton collider beamstrahlung ' // & 'structure function \circeone. If not set, $\sqrt{s}$ is taken. ' // & '(cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_generate"), .true., & intrinsic=.true., & description=var_str ('Flag that determines whether the \circeone\ ' // & 'structure function for lepton collider beamstrahlung uses the ' // & 'generator mode for the spectrum, or a pre-defined (semi-)analytical ' // & 'parameterization. Default is the generator mode. (cf. also ' // & '\ttt{circe1}, \ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_map}, \ttt{circe1\_mapping\_slope}, ' // & '\ttt{circe1\_eps}, \newline \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // & '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_map"), .true., & intrinsic=.true., & description=var_str ('Flag that determines whether the \circeone\ ' // & 'structure function for lepton collider beamstrahlung uses special ' // & 'mappings for $s$-channel resonances. (cf. also \ttt{circe1}, ' // & '\ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // & '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_eps}, \newline ' // & '\ttt{circe1\_ver}, \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, ' // & '\ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_real (var_str ("circe1_mapping_slope"), 2._default, & intrinsic=.true., & description=var_str ('Real parameter that allows to vary the ' // & 'slope of the mapping function for the \circeone\ structure ' // & 'function for lepton collider beamstrahlung from the default ' // & 'value \ttt{2.}. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // & '\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // & '\ttt{?circe1\_map}, \ttt{circe1\_eps}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_real (var_str ("circe1_eps"), 1e-5_default, & intrinsic=.true., & description=var_str ('Real parameter, that takes care of the ' // & 'mapping of the peak in the lepton collider beamstrahlung structure ' // & 'function spectrum of \circeone. (cf. also \ttt{circe1}, \ttt{?circe1\_photons}, ' // & '\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // & '\ttt{?circe1\_map}, \ttt{circe1\_eps}, \newline ' // & '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // & '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline\ttt{?circe1\_with\_radiation})')) call var_list%append_int (var_str ("circe1_ver"), 0, intrinsic=.true., & description=var_str ('Integer parameter that sets the internal ' // & 'versioning number of the \circeone\ structure function for lepton-collider ' // & 'beamstrahlung. It has to be set by the user explicitly, it takes ' // & 'values from one to ten. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // & '\ttt{?circe1\_photon2}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_int (var_str ("circe1_rev"), 0, intrinsic=.true., & description=var_str ('Integer parameter that sets the internal ' // & 'revision number of the \circeone\ structure function for lepton-collider ' // & 'beamstrahlung. The default \ttt{0} translates always into the ' // & 'most recent version; older versions have to be accessed through ' // & 'the explicit revision date. For more details cf.~the \circeone ' // & 'manual. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, \ttt{circe1\_ver}, ' // & '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_string (var_str ("$circe1_acc"), var_str ("SBAND"), & intrinsic=.true., & description=var_str ('String variable that specifies the accelerator ' // & 'type for the \circeone\ structure function for lepton-collider ' // & 'beamstrahlung. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\newline \ttt{circe1\_rev}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_int (var_str ("circe1_chat"), 0, intrinsic=.true., & description=var_str ('Chattiness of the \circeone\ structure ' // & 'function for lepton-collider beamstrahlung. The higher the integer ' // & 'value, the more information will be given out by the \circeone\ ' // & 'package. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_with_radiation"), .false., & intrinsic=.true., & description=var_str ('This logical decides whether the additional photon ' // & 'or electron ("beam remnant") will be considered in the event record or ' // & 'not. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc})')) call var_list%append_log (var_str ("?circe2_polarized"), .true., & intrinsic=.true., & description=var_str ('Flag whether the photon spectra from the ' // & '\circetwo\ structure function for lepton colliders should be ' // & 'treated polarized. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, ' // & '\ttt{\$circe2\_design})')) call var_list%append_string (var_str ("$circe2_file"), & intrinsic=.true., & description=var_str ('String variable by which the corresponding ' // & 'photon collider spectrum for the \circetwo\ structure function ' // & 'can be selected. (cf. also \ttt{circe2}, \ttt{?circe2\_polarized}, ' // & '\ttt{\$circe2\_design})')) call var_list%append_string (var_str ("$circe2_design"), var_str ("*"), & intrinsic=.true., & description=var_str ('String variable that sets the collider ' // & 'design for the \circetwo\ structure function for photon collider ' // & 'spectra. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, \ttt{?circe2\_polarized})')) call var_list%append_real (var_str ("gaussian_spread1"), 0._default, & intrinsic=.true., & description=var_str ('Parameter that sets the energy spread ' // & '($\sigma$ value) of the first beam for a Gaussian spectrum. ' // & '(cf. \ttt{gaussian})')) call var_list%append_real (var_str ("gaussian_spread2"), 0._default, & intrinsic=.true., & description=var_str ('Ditto, for the second beam.')) call var_list%append_string (var_str ("$beam_events_file"), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & "name of the external file from which a beamstrahlung's spectrum " // & 'for lepton colliders as pairs of energy fractions is read in. ' // & '(cf. also \ttt{beam\_events}, \ttt{?beam\_events\_warn\_eof})')) call var_list%append_log (var_str ("?beam_events_warn_eof"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to ' // & 'issue a warning when in a simulation the end of an external ' // & "file for beamstrahlung's spectra for lepton colliders are reached, " // & 'and energy fractions from the beginning of the file are reused. ' // & '(cf. also \ttt{beam\_events}, \ttt{\$beam\_events\_file})')) call var_list%append_log (var_str ("?energy_scan_normalize"), .false., & intrinsic=.true., & description=var_str ('Normalization flag for the energy scan ' // & 'structure function: if set the total cross section is normalized ' // & 'to unity. (cf. also \ttt{energy\_scan})')) call var_list%append_string (var_str ("$negative_sf"), var_str ("default"), & intrinsic=.true., & description=var_str ('String variable to set the behavior to either ' // & 'keep negative structure function/PDF values or set them to zero. ' // & 'The default (\ttt{"default"}) takes the first option for NLO and the ' // & 'second for LO processes. Explicit behavior can be set with ' // & '\ttt{"positive"} or \ttt{"negative"}.')) end subroutine var_list_set_beams_defaults @ %def var_list_set_beams_defaults @ <>= procedure :: set_core_defaults => var_list_set_core_defaults <>= subroutine var_list_set_core_defaults (var_list, seed) class(var_list_t), intent(inout) :: var_list integer, intent(in) :: seed logical, target, save :: known = .true. !!! ?????? real(default), parameter :: real_specimen = 1. call var_list_append_log_ptr & (var_list, var_str ("?logging"), logging, known, & intrinsic=.true., & description=var_str ('This logical -- when set to \ttt{false} ' // & '-- suppresses writing out a logfile (default: \ttt{whizard.log}) ' // & 'for the whole \whizard\ run, or when \whizard\ is run with the ' // & '\ttt{--no-logging} option, to suppress parts of the logging ' // & 'when setting it to \ttt{true} again at a later part of the ' // & '\sindarin\ input file. Mainly for debugging purposes. ' // & '(cf. also \ttt{?openmp\_logging}, \ttt{?mpi\_logging})')) call var_list%append_string (var_str ("$job_id"), & intrinsic=.true., & description=var_str ('Arbitrary string that can be used for ' // & 'creating unique names. The variable is initialized with the ' // & 'value of the \ttt{job\_id} option on startup. (cf. also ' // & '\ttt{\$compile\_workspace}, \ttt{\$run\_id})')) call var_list%append_string (var_str ("$compile_workspace"), & intrinsic=.true., & description=var_str ('If set, create process source code ' // & 'and process-driver library code in a subdirectory with this ' // & 'name. If non-existent, the directory will be created. (cf. ' // & 'also \ttt{\$job\_id}, \ttt{\$run\_id}, \ttt{\$integrate\_workspace})')) call var_list%append_int (var_str ("seed"), seed, & intrinsic=.true., & description=var_str ('Integer variable \ttt{seed = {\em }} ' // & 'that allows to set a specific random seed \ttt{num}. If not ' // & 'set, \whizard\ takes the time from the system clock to determine ' // & 'the random seed.')) call var_list%append_string (var_str ("$model_name"), & intrinsic=.true., & description=var_str ('This variable makes the locally used physics ' // & 'model available as a string, e.g. as \ttt{show (\$model\_name)}. ' // & 'However, the user is not able to change the current model by ' // & 'setting this variable to a different string. (cf. also \ttt{model}, ' // & '\ttt{\$library\_name}, \ttt{printf}, \ttt{show})')) call var_list%append_int (var_str ("process_num_id"), & intrinsic=.true., & description=var_str ('Using the integer \ttt{process\_num\_id ' // & '= {\em }} one can set a numerical identifier for processes ' // & 'within a process library. This can be set either just before ' // & 'the corresponding \ttt{process} definition or as an optional ' // & 'local argument of the latter. (cf. also \ttt{process}, ' // & '\ttt{?proc\_as\_run\_id}, \ttt{lcio\_run\_id})')) call var_list%append_log (var_str ("?proc_as_run_id"), .true., & intrinsic=.true., & description=var_str ('Normally, for LCIO the process ID (cf. ' // & '\ttt{process\_num\_id}) is used as run ID, unless this flag is ' // & 'set to \ttt{false}, cf. also \ttt{process}, \ttt{lcio\_run\_id}.')) call var_list%append_int (var_str ("lcio_run_id"), 0, & intrinsic=.true., & description=var_str ('Allows to set an integer run ID for the LCIO ' // & 'event format. Normally, the process ID is taken as run ID, unless ' // & 'the flag (cf.) \ttt{?proc\_as\_run\_id} is set to \ttt{false}, ' // & 'cf. also \ttt{process}.')) call var_list%append_string (var_str ("$method"), var_str ("omega"), & intrinsic=.true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation. The default ' // & "is the intrinsic \oMega\ matrix element generator " // & '(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // & '\ttt{"template\_unity"}, \ttt{"threshold"}. For processes defined ' // & '\ttt{"template"}, with \ttt{nlo\_calculation = ...}, please refer to ' // & '\ttt{\$born\_me\_method}, \ttt{\$real\_tree\_me\_method}, ' // & '\ttt{\$loop\_me\_method} and \ttt{\$correlation\_me\_method}.')) call var_list%append_log (var_str ("?report_progress"), .true., & intrinsic=.true., & description=var_str ('Flag for the \oMega\ matrix element generator ' // & 'whether to print out status messages about progress during ' // & 'matrix element generation. (cf. also \ttt{\$method}, \ttt{\$omega\_flags})')) call var_list%append_log (var_str ("?me_verbose"), .false., & description=var_str ("Flag determining whether " // & "the makefile command for generating and compiling the \oMega\ matrix " // & "element code is silent or verbose. Default is silent.")) call var_list%append_string (var_str ("$restrictions"), var_str (""), & intrinsic=.true., & description=var_str ('This is an optional argument for process ' // & 'definitions for the matrix element method \ttt{"omega"}. Using ' // & 'the following construction, it defines a string variable, \ttt{process ' // & '\newline {\em } = {\em }, {\em } ' // & '=> {\em }, {\em }, ... \{ \$restrictions ' // & '= "{\em }" \}}. The string argument \ttt{{\em ' // & '}} is directly transferred during the code ' // & 'generation to the ME generator \oMega. It has to be of the form ' // & '\ttt{n1 + n2 + ... \url{~} {\em }}, where ' // & '\ttt{n1} and so on are the numbers of the particles above in ' // & 'the process definition. The tilde specifies a certain intermediate ' // & 'state to be equal to the particle(s) in \ttt{particle (list)}. ' // & 'An example is \ttt{process eemm\_z = e1, E1 => e2, E2 ' // & '\{ \$restrictions = "1+2 \url{~} Z" \} } restricts the code ' // & 'to be generated for the process $e^- e^+ \to \mu^- \mu^+$ to ' // & 'the $s$-channel $Z$-boson exchange. For more details see Sec.~\ref{sec:omega_me} ' // & '(cf. also \ttt{process})')) call var_list%append_log (var_str ("?omega_write_phs_output"), .false., & intrinsic=.true., & description=var_str ('This flag decides whether a the phase-space ' // & 'output is produced by the \oMega\ matrix element generator. This ' // & 'output is written to file(s) and contains the Feynman diagrams ' // & 'which belong to the process(es) under consideration. The file is ' // & 'mandatory whenever the variable \ttt{\$phs\_method} has the value ' // & '\ttt{fast\_wood}, i.e. if the phase-space file is provided by ' // & 'cascades2.')) call var_list%append_string (var_str ("$omega_flags"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass flags ' // & 'to the \oMega\ matrix element generator. Normally, \whizard\ ' // & 'takes care of all flags automatically. Note that for restrictions ' // & 'of intermediate states, there is a special string variable: ' // & '(cf. $\to$) \ttt{\$restrictions}.')) call var_list%append_log (var_str ("?read_color_factors"), .true., & intrinsic=.true., & description=var_str ('This flag decides whether to read QCD ' // & 'color factors from the matrix element provided by each method, ' // & 'or to try and calculate the color factors in \whizard\ internally.')) call var_list%append_log (var_str ("?slha_read_input"), .true., & intrinsic=.true., & description=var_str ('Flag which decides whether \whizard\ reads ' // & 'in the SM and parameter information from the \ttt{SMINPUTS} ' // & 'and \ttt{MINPAR} common blocks of the SUSY Les Houches Accord ' // & 'files. (cf. also \ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, ' // & '\ttt{?slha\_read\_decays})')) call var_list%append_log (var_str ("?slha_read_spectrum"), .true., & intrinsic=.true., & description=var_str ('Flag which decides whether \whizard\ reads ' // & 'in the whole spectrum and mixing angle information from the ' // & 'common blocks of the SUSY Les Houches Accord files. (cf. also ' // & '\ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_decays}, ' // & '\ttt{?slha\_read\_input})')) call var_list%append_log (var_str ("?slha_read_decays"), .false., & intrinsic=.true., & description=var_str ('Flag which decides whether \whizard\ reads ' // & 'in the widths and branching ratios from the \ttt{DCINFO} common ' // & 'block of the SUSY Les Houches Accord files. (cf. also \ttt{read\_slha}, ' // & '\ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, \ttt{?slha\_read\_input})')) call var_list%append_string (var_str ("$library_name"), & intrinsic=.true., & description=var_str ('Similar to \ttt{\$model\_name}, this string ' // & 'variable is used solely to access the name of the active process ' // & 'library, e.g. in \ttt{printf} statements. (cf. \ttt{compile}, ' // & '\ttt{library}, \ttt{printf}, \ttt{show}, \ttt{\$model\_name})')) call var_list%append_log (var_str ("?alphas_is_fixed"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a non-running ' // & 'QCD $\alpha_s$. Note that this has to be set explicitly to $\ttt{false}$ ' // & 'if the user wants to use one of the running $\alpha_s$ options. ' // & '(cf. also \ttt{alphas\_order}, \ttt{?alphas\_from\_lhapdf}, ' // & '\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // & '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alpha_is_fixed"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a non-running ' // & 'QED $\alpha$. Note that this has to be set explicitly to $\ttt{false}$ ' // & 'if the user wants to use one of the running $\alpha$ options. ' // & '(cf. also \ttt{alpha\_order}, \ttt{alpha\_nf}, \ttt{alpha\_lep}, ' // & '\ttt{?alphas\_from\_me}')) call var_list%append_log (var_str ("?alphas_from_lhapdf"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a running ' // & '$\alpha_s$ from the \lhapdf\ library (which has to be correctly ' // & 'linked). Note that \ttt{?alphas\_is\_fixed} has to be set ' // & 'explicitly to $\ttt{false}$. (cf. also \ttt{alphas\_order}, ' // & '\ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // & '\ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alphas_from_pdf_builtin"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a running ' // & '$\alpha_s$ from the internal PDFs. Note that in that case \ttt{?alphas\_is\_fixed} ' // & 'has to be set explicitly to $\ttt{false}$. (cf. also ' // & '\ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // & '\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \newline \ttt{?alphas\_from\_lambda\_qcd}, ' // & '\ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alpha_evolve_analytic"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use analytic running ' // & 'formulae for $\alpha$ instead of a numeric Runge-Kutta. ' // & '(cf. also \ttt{alpha\_order}, \ttt{?alpha\_is\_fixed}, ' // & '\ttt{alpha\_nf}, \ttt{alpha\_nlep}, \ttt{?alpha\_from\_me}) ')) call var_list%append_int (var_str ("alphas_order"), 0, & intrinsic=.true., & description=var_str ('Integer parameter that sets the order ' // & 'of the internal evolution for running $\alpha_s$ in \whizard: ' // & 'the default, \ttt{0}, is LO running, \ttt{1} is NLO, \ttt{2} ' // & 'is NNLO. (cf. also \ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // & '\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // & '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_int (var_str ("alpha_order"), 0, & intrinsic=.true., & description=var_str ('Integer parameter that sets the order ' // & 'of the internal evolution for running $\alpha$ in \whizard: ' // & 'the default, \ttt{0}, is LO running, \ttt{1} is NLO. ' // & '(cf. also \ttt{alpha\_is\_fixed}, \ttt{alpha\_nf}, \ttt{alphas\_lep}, ' // & '\ttt{?alpha\_from\_me})')) call var_list%append_int (var_str ("alphas_nf"), 5, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of active quark flavors for the internal evolution for running ' // & '$\alpha_s$ in \whizard. (cf. also ' // & '\ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\ttt{alphas\_order}, \ttt{?alphas\_from\_mz}, \newline ' // & '\ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_int (var_str ("alpha_nf"), -1, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of active quark flavors for the internal evolution for running ' // & '$\alpha$ in \whizard. The default, \ttt{-1}, keeps it equal to \ttt{alphas\_nf} ' // & '\ttt{alpha\_is\_fixed}, \ttt{alphas\_order}, \ttt{?alpha\_from\_me}, ' // & '\ttt{?alpha\_evolve\_analytic}')) call var_list%append_int (var_str ("alpha_nlep"), 1, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of active leptons in the running of $\alpha$ in \whizard. The deffault is' // & 'one, with only the electron considered massless (cf. also ' // & '\ttt{alpha\_is\_fixed}, \ttt{alpha\_nf}, ' // & '\ttt{alpha\_order}, \ttt{?alpha\_from\_me}, \ttt{?alpha\_evolve\_analytic})')) call var_list%append_log (var_str ("?alphas_from_mz"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use its internal ' // & 'running $\alpha_s$ from $\alpha_s(M_Z)$. Note that in that ' // & 'case \ttt{?alphas\_is\_fixed} has to be set explicitly to ' // & '$\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // & '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alphas_from_lambda_qcd"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use its internal ' // & 'running $\alpha_s$ from $\alpha_s(\Lambda_{QCD})$. Note that ' // & 'in that case \ttt{?alphas\_is\_fixed} has to be set explicitly ' // & 'to $\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // & '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\newline \ttt{?alphas\_from\_mz}, \ttt{lambda\_qcd})')) call var_list%append_real (var_str ("lambda_qcd"), 200.e-3_default, & intrinsic=.true., & description=var_str ('Real parameter that sets the value for ' // & '$\Lambda_{QCD}$ used in the internal evolution for running ' // & '$\alpha_s$ in \whizard. (cf. also \ttt{alphas\_is\_fixed}, ' // & '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, ' // & '\newline \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // & '\ttt{alphas\_order})')) call var_list%append_log (var_str ("?fatal_beam_decay"), .true., & intrinsic=.true., & description=var_str ('Logical variable that let the user decide ' // & 'whether the possibility of a beam decay is treated as a fatal ' // & 'error or only as a warning. An example is a process $b t \to ' // & 'X$, where the bottom quark as an inital state particle appears ' // & 'as a possible decay product of the second incoming particle, ' // & 'the top quark. This might trigger inconsistencies or instabilities ' // & 'in the phase space set-up.')) call var_list%append_log (var_str ("?helicity_selection_active"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether \whizard\ uses ' // & 'a numerical selection rule for vanishing helicities: if active, ' // & 'then, if a certain helicity combination yields an absolute ' // & '(\oMega) matrix element smaller than a certain threshold ($\to$ ' // & '\ttt{helicity\_selection\_threshold}) more often than a certain ' // & 'cutoff ($\to$ \ttt{helicity\_selection\_cutoff}), it will be dropped.')) call var_list%append_real (var_str ("helicity_selection_threshold"), & 1E10_default, & intrinsic=.true., & description=var_str ('Real parameter that gives the threshold ' // & 'for the absolute value of a certain helicity combination of ' // & 'an (\oMega) amplitude. If a certain number ($\to$ ' // & '\ttt{helicity\_selection\_cutoff}) of calls stays below this ' // & 'threshold, that combination will be dropped from then on. (cf. ' // & 'also \ttt{?helicity\_selection\_active})')) call var_list%append_int (var_str ("helicity_selection_cutoff"), 1000, & intrinsic=.true., & description=var_str ('Integer parameter that gives the number ' // & "a certain helicity combination of an (\oMega) amplitude has " // & 'to be below a certain threshold ($\to$ \ttt{helicity\_selection\_threshold}) ' // & 'in order to be dropped from then on. (cf. also \ttt{?helicity\_selection\_active})')) call var_list%append_string (var_str ("$rng_method"), var_str ("tao"), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'method for the random number generation. Default is Donald ' // & "Knuth' RNG method \ttt{TAO}.")) call var_list%append_log (var_str ("?vis_diags"), .false., & intrinsic=.true., & description=var_str ('Logical variable that allows to give out ' // & "a Postscript or PDF file for the Feynman diagrams for a \oMega\ " // & 'process. (cf. \ttt{?vis\_diags\_color}).')) call var_list%append_log (var_str ("?vis_diags_color"), .false., & intrinsic=.true., & description=var_str ('Same as \ttt{?vis\_diags}, but switches ' // & 'on color flow instead of Feynman diagram generation. (cf. \ttt{?vis\_diags}).')) call var_list%append_log (var_str ("?check_event_file"), .true., & intrinsic=.true., & description=var_str ('Setting this to false turns off all sanity ' // & 'checks when reading a raw event file with previously generated ' // & 'events. Use this at your own risk; the program may return ' // & 'wrong results or crash if data do not match. (cf. also \ttt{?check\_grid\_file}, ' // & '\ttt{?check\_phs\_file})')) call var_list%append_string (var_str ("$event_file_version"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'format version of the \whizard\ internal binary event format.')) call var_list%append_int (var_str ("n_events"), 0, & intrinsic=.true., & description=var_str ('This specifier \ttt{n\_events = {\em }} ' // & 'sets the number of events for the event generation of the processes ' // & 'in the \sindarin\ input files. Note that WHIZARD itself chooses ' // & 'the number from the \ttt{n\_events} or from the \ttt{luminosity} ' // & 'specifier, whichever would give the larger number of events. ' // & 'As this depends on the cross section under consideration, it ' // & 'might be different for different processes in the process list. ' // & '(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?unweighted}, \ttt{event\_index\_offset})')) call var_list%append_int (var_str ("event_index_offset"), 0, & intrinsic=.true., & description=var_str ('The value ' // & '\ttt{event\_index\_offset = {\em }} ' // & 'initializes the event counter for a subsequent ' // & 'event sample. By default (value 0), the first event ' // & 'gets index value 1, incrementing by one for each generated event ' // & 'within a sample. The event counter is initialized again ' // & 'for each new sample (i.e., \ttt{integrate} command). ' // & 'If events are read from file, and the ' // & 'event file format supports event numbering, the event numbers ' // & 'will be taken from file instead, and the value of ' // & '\ttt{event\_index\_offset} has no effect. ' // & '(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?unweighted}, \ttt{n\_events})')) call var_list%append_log (var_str ("?unweighted"), .true., & intrinsic=.true., & description=var_str ('Flag that distinguishes between unweighted ' // & 'and weighted event generation. (cf. also \ttt{simulate}, \ttt{n\_events}, ' // & '\ttt{luminosity}, \ttt{event\_index\_offset})')) call var_list%append_real (var_str ("safety_factor"), 1._default, & intrinsic=.true., & description=var_str ('This real variable \ttt{safety\_factor ' // & '= {\em }} reduces the acceptance probability for unweighting. ' // & 'If greater than one, excess events become less likely, but ' // & 'the reweighting efficiency also drops. (cf. \ttt{simulate}, \ttt{?unweighted})')) call var_list%append_log (var_str ("?negative_weights"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to allow negative ' // & 'weights in integration and simulation. (cf. also \ttt{simulate}, ' // & '\ttt{?unweighted})')) call var_list%append_log (var_str ("?resonance_history"), .false., & intrinsic=.true., & description=var_str ( & 'The logical variable \texttt{?resonance\_history ' // & '= true/false} specifies whether during a simulation pass, ' // & 'the event generator should try to reconstruct intermediate ' // & 'resonances. If activated, appropriate resonant subprocess ' // & 'matrix element code will be automatically generated. ')) call var_list%append_real (var_str ("resonance_on_shell_limit"), & 4._default, & intrinsic=.true., & description=var_str ( & 'The real variable \texttt{resonance\_on\_shell\_limit ' // & '= {\em }} specifies the maximum relative distance from a ' // & 'resonance peak, such that the kinematical configuration ' // & 'can still be considered on-shell. This is relevant only if ' // & '\texttt{?resonance\_history = true}.')) call var_list%append_real (var_str ("resonance_on_shell_turnoff"), & 0._default, & intrinsic=.true., & description=var_str ( & 'The real variable \texttt{resonance\_on\_shell\_turnoff ' // & '= {\em }}, if positive, ' // & 'controls the smooth transition from resonance-like ' // & 'to background-like events. The relative strength of a ' // & 'resonance is reduced by a Gaussian with width given by this ' // & 'variable. In any case, events are treated as background-like ' // & 'when the off-shellness is greater than ' // & '\texttt{resonance\_on\_shell\_limit}. All of this applies ' // & 'only if \texttt{?resonance\_history = true}.')) call var_list%append_real (var_str ("resonance_background_factor"), & 1._default, & intrinsic=.true., & description=var_str ( & 'The real variable \texttt{resonance\_background\_factor} ' // & 'controls resonance insertion if a resonance ' // & 'history applies to a particular event. In determining '// & 'whether event kinematics qualifies as resonant or non-resonant, ' //& 'the non-resonant probability is multiplied by this factor ' // & 'Setting the factor to zero removes the background ' // & 'configuration as long as the kinematics qualifies as on-shell ' // & 'as qualified by \texttt{resonance\_on\_shell\_limit}.')) call var_list%append_log (var_str ("?keep_beams"), .false., & intrinsic=.true., & description=var_str ('The logical variable \ttt{?keep\_beams ' // & '= true/false} specifies whether beam particles and beam remnants ' // & 'are included when writing event files. For example, in order ' // & 'to read Les Houches accord event files into \pythia, no beam ' // & 'particles are allowed.')) call var_list%append_log (var_str ("?keep_remnants"), .true., & intrinsic=.true., & description=var_str ('The logical variable \ttt{?keep\_beams ' // & '= true/false} is respected only if \ttt{?keep\_beams} is set. ' // & 'If \ttt{true}, beam remnants are tagged as outgoing particles ' // & 'if they have been neither showered nor hadronized, i.e., have ' // & 'no children. If \ttt{false}, beam remnants are also included ' // & 'in the event record, but tagged as unphysical. Note that for ' // & 'ISR and/or beamstrahlung spectra, the radiated photons are ' // & 'considered as beam remnants.')) call var_list%append_log (var_str ("?rescan_force"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to bypass essential ' // & 'checks on the particle set when reading event/rescanning files ' // & 'into \whizard. (cf. \ttt{rescan}, \ttt{?update\_event}, \ttt{?update\_sqme}, ' // & '\newline \ttt{?update\_weight})')) call var_list%append_log (var_str ("?recover_beams"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether the beam particles ' // & 'should be reconstructed when reading event/rescanning files ' // & 'into \whizard. (cf. \ttt{rescan}, \ttt{?update\_event}, \ttt{?update\_sqme}, ' // & '\newline \ttt{?update\_weight})')) call var_list%append_log (var_str ("?update_event"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the events in ' // & 'an event file should be rebuilt from the hard process when ' // & 'reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // & '\ttt{?recover\_beams}, \ttt{?update\_sqme}, \ttt{?update\_weight})')) call var_list%append_log (var_str ("?update_sqme"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the squared ' // & 'matrix element in an event file should be updated/recalculated ' // & 'when reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // & '\newline \ttt{?recover\_beams}, \ttt{?update\_event}, \ttt{?update\_weight})')) call var_list%append_log (var_str ("?update_weight"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the weights ' // & 'in an event file should be updated/recalculated when reading ' // & 'event/rescanning files into \whizard. (cf. \ttt{rescan}, \ttt{?recover\_beams}, ' // & '\newline \ttt{?update\_event}, \ttt{?update\_sqme})')) call var_list%append_log (var_str ("?use_alphas_from_file"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the current ' // & '$\alpha_s$ definition should be used when recalculating matrix ' // & 'elements for events read from file, or the value that is stored ' // & 'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // & '\ttt{?use\_scale\_from\_file})')) call var_list%append_log (var_str ("?use_scale_from_file"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the current ' // & 'energy-scale expression should be used when recalculating matrix ' // & 'elements for events read from file, or the value that is stored ' // & 'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // & '\ttt{?use\_alphas\_from\_file})')) call var_list%append_log (var_str ("?allow_decays"), .true., & intrinsic=.true., & description=var_str ('Master flag to switch on cascade decays ' // & 'for final state particles as an event transform. As a default, ' // & 'it is switched on. (cf. also \ttt{?auto\_decays}, ' // & '\ttt{auto\_decays\_multiplicity}, \ttt{?auto\_decays\_radiative}, ' // & '\ttt{?decay\_rest\_frame})')) call var_list%append_log (var_str ("?auto_decays"), .false., & intrinsic=.true., & description=var_str ('Flag, particularly as optional argument of the ($\to$) ' // & '\ttt{unstable} command, that tells \whizard\ to automatically ' // & 'determine the decays of that particle up to the final state ' // & 'multplicity ($\to$) \ttt{auto\_decays\_multiplicity}. Depending ' // & 'on the flag ($\to$) \ttt{?auto\_decays\_radiative}, radiative ' // & 'decays will be taken into account or not. (cf. also \ttt{unstable}, ' // & '\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay})')) call var_list%append_int (var_str ("auto_decays_multiplicity"), 2, & intrinsic=.true., & description=var_str ('Integer parameter, that sets -- ' // & 'for the ($\to$) \ttt{?auto\_decays} option to let \whizard\ ' // & 'automatically determine the decays of a particle set as ($\to$) ' // & '\ttt{unstable} -- the maximal final state multiplicity that ' // & 'is taken into account. The default is \ttt{2}. The flag \ttt{?auto\_decays\_radiative} ' // & 'decides whether radiative decays are taken into account. (cf.\ ' // & 'also \ttt{unstable}, \ttt{?auto\_decays})')) call var_list%append_log (var_str ("?auto_decays_radiative"), .false., & intrinsic=.true., & description=var_str ("If \whizard's automatic detection " // & 'of decay channels are switched on ($\to$ \ttt{?auto\_decays} ' // & 'for the ($\to$) \ttt{unstable} command, this flags decides ' // & 'whether radiative decays (e.g. containing additional photon(s)/gluon(s)) ' // & 'are taken into account or not. (cf. also \ttt{unstable}, \ttt{auto\_decays\_multiplicity})')) call var_list%append_log (var_str ("?decay_rest_frame"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to force a particle decay ' // & 'to be simulated in its rest frame. This simplifies the calculation ' // & 'for decays as stand-alone processes, but makes the process ' // & 'unsuitable for use in a decay chain.')) call var_list%append_log (var_str ("?isotropic_decay"), .false., & intrinsic=.true., & description=var_str ('Flag that -- in case of using factorized ' // & 'production and decays using the ($\to$) \ttt{unstable} command ' // & '-- tells \whizard\ to switch off spin correlations completely ' // & '(isotropic decay). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // & '\ttt{decay\_helicity}, \ttt{?diagonal\_decay})')) call var_list%append_log (var_str ("?diagonal_decay"), .false., & intrinsic=.true., & description=var_str ('Flag that -- in case of using factorized ' // & 'production and decays using the ($\to$) \ttt{unstable} command ' // & '-- tells \whizard\ instead of full spin correlations to take ' // & 'only the diagonal entries in the spin-density matrix (i.e. ' // & 'classical spin correlations). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // & '\ttt{decay\_helicity}, \ttt{?isotropic\_decay})')) call var_list%append_int (var_str ("decay_helicity"), & intrinsic=.true., & description=var_str ('If this parameter is given an integer ' // & 'value, any particle decay triggered by a subsequent \ttt{unstable} ' // & 'declaration will receive a projection on the given helicity ' // & 'state for the unstable particle. (cf. also \ttt{unstable}, ' // & '\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay}. The latter ' // & 'parameters, if true, take precdence over any \ttt{?decay\_helicity} setting.)')) call var_list%append_log (var_str ("?polarized_events"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to select certain helicity ' // & 'combinations in final state particles in the event files, ' // & 'and perform analysis on polarized event samples. (cf. also ' // & '\ttt{simulate}, \ttt{polarized}, \ttt{unpolarized})')) call var_list%append_string (var_str ("$polarization_mode"), & var_str ("helicity"), & intrinsic=.true., & description=var_str ('String variable that specifies the mode in ' // & 'which the polarization of particles is handled when polarized events ' // & 'are written out. Possible options are \ttt{"ignore"}, \ttt{"helicity"}, ' // & '\ttt{"factorized"}, and \ttt{"correlated"}. For more details cf. the ' // & 'detailed section.')) call var_list%append_log (var_str ("?colorize_subevt"), .false., & intrinsic=.true., & description=var_str ('Flag that enables color-index tracking ' // & 'in the subevent (\ttt{subevt}) objects that are used for ' // & 'internal event analysis.')) call var_list%append_real (var_str ("tolerance"), 0._default, & intrinsic=.true., & description=var_str ('Real variable that defines the absolute ' // & 'tolerance with which the (logical) function \ttt{expect} accepts ' // & 'equality or inequality: \ttt{tolerance = {\em }}. This ' // & 'can e.g. be used for cross-section tests and backwards compatibility ' // & 'checks. (cf. also \ttt{expect})')) call var_list%append_int (var_str ("checkpoint"), 0, & intrinsic = .true., & description=var_str ('Setting this integer variable to a positive ' // & 'integer $n$ instructs simulate to print out a progress summary ' // & 'every $n$ events.')) call var_list%append_int (var_str ("event_callback_interval"), 0, & intrinsic = .true., & description=var_str ('Setting this integer variable to a positive ' // & 'integer $n$ instructs simulate to print out a progress summary ' // & 'every $n$ events.')) call var_list%append_log (var_str ("?pacify"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to suppress numerical ' // & 'noise and give screen and log file output with a lower number ' // & 'of significant digits. Mainly for debugging purposes. (cf. also ' // & '\ttt{?sample\_pacify})')) call var_list%append_string (var_str ("$out_file"), var_str (""), & intrinsic=.true., & description=var_str ('This character variable allows to specify ' // & 'the name of the data file to which the histogram and plot data ' // & 'are written (cf. also \ttt{write\_analysis}, \ttt{open\_out}, ' // & '\ttt{close\_out})')) call var_list%append_log (var_str ("?out_advance"), .true., & intrinsic=.true., & description=var_str ('Flag that sets advancing in the \ttt{printf} ' // & 'output commands, i.e. continuous printing with no line feed ' // & 'etc. (cf. also \ttt{printf})')) call var_list%append_int (var_str ("real_range"), & range (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This integer gives the decimal exponent ' // & 'range of the numeric model for the real float type in use. It cannot ' // & 'be set by the user. (cf. also \ttt{real\_precision}, ' // & '\ttt{real\_epsilon}, \ttt{real\_tiny}).')) call var_list%append_int (var_str ("real_precision"), & precision (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This integer gives the precision of ' // & 'the numeric model for the real float type in use. It cannot ' // & 'be set by the user. (cf. also \ttt{real\_range}, ' // & '\ttt{real\_epsilon}, \ttt{real\_tiny}).')) call var_list%append_real (var_str ("real_epsilon"), & epsilon (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This gives the smallest number $E$ ' // & 'of the same kind as the float type for which $1 + E > 1$. ' // & 'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // & '\ttt{real\_tiny}, \ttt{real\_precision}).')) call var_list%append_real (var_str ("real_tiny"), & tiny (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This gives the smallest positive (non-zero) ' // & 'number in the numeric model for the real float type in use. ' // & 'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // & '\ttt{real\_epsilon}, \ttt{real\_precision}).')) end subroutine var_list_set_core_defaults @ %def var_list_set_core_defaults @ <>= procedure :: set_integration_defaults => var_list_set_integration_defaults <>= subroutine var_list_set_integration_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$integration_method"), var_str ("vamp"), & intrinsic=.true., & description=var_str ('This string variable specifies the method ' // & 'for performing the multi-dimensional phase-space integration. ' // & 'The default is the \vamp\ algorithm (\ttt{"vamp"}), other options ' // & 'are via the numerical midpoint rule (\ttt{"midpoint"}) or an ' // & 'alternate \vamptwo\ implementation that is MPI-parallelizable ' // & '(\ttt{"vamp2"}).')) call var_list%append_int (var_str ("threshold_calls"), 10, & intrinsic=.true., & description=var_str ('This integer variable gives a limit for ' // & 'the number of calls in a given channel which acts as a lower ' // & 'threshold for the channel weight. If the number of calls in ' // & 'that channel falls below this threshold, the weight is not ' // & 'lowered further but kept at this threshold. (cf. also ' // & '\ttt{channel\_weights\_power})')) call var_list%append_int (var_str ("min_calls_per_channel"), 10, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the minimal " // & 'number every channel must be called. If the number of calls ' // & 'from the iterations is too small, \whizard\ will automatically ' // & 'increase the number of calls. (cf. \ttt{iterations}, \ttt{min\_calls\_per\_bin}, ' // & '\ttt{min\_bins}, \ttt{max\_bins})')) call var_list%append_int (var_str ("min_calls_per_bin"), 10, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the minimal " // & 'number every bin in an integration dimension must be called. ' // & 'If the number of calls from the iterations is too small, \whizard\ ' // & 'will automatically increase the number of calls. (cf. \ttt{iterations}, ' // & '\ttt{min\_calls\_per\_channel}, \ttt{min\_bins}, \ttt{max\_bins})')) call var_list%append_int (var_str ("min_bins"), 3, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the minimal " // & 'number of bins per integration dimension. (cf. \ttt{iterations}, ' // & '\ttt{max\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})')) call var_list%append_int (var_str ("max_bins"), 20, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the maximal " // & 'number of bins per integration dimension. (cf. \ttt{iterations}, ' // & '\ttt{min\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})')) call var_list%append_log (var_str ("?stratified"), .true., & intrinsic=.true., & description=var_str ('Flag that switches between stratified ' // & 'and importance sampling for the \vamp\ integration method.')) call var_list%append_log (var_str ("?use_vamp_equivalences"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether equivalence ' // & 'relations (symmetries) between different integration channels ' // & 'are used by the \vamp\ integrator.')) call var_list%append_log (var_str ("?vamp_verbose"), .false., & intrinsic=.true., & description=var_str ('Flag that sets the chattiness of the \vamp\ ' // & 'integrator. If set, not only errors, but also all warnings and ' // & 'messages will be written out (not the default). (cf. also \newline ' // & '\ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_global\_verbose}, ' // & '\ttt{?vamp\_history\_channels}, \newline \ttt{?vamp\_history\_channels\_verbose})')) call var_list%append_log (var_str ("?vamp_history_global"), & .true., intrinsic=.true., & description=var_str ('Flag that decides whether the global history ' // & 'of the grid adaptation of the \vamp\ integrator are written ' // & 'into the process logfiles. (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // & '\ttt{?vamp\_history\_channels}, \ttt{?vamp\_history\_channels\_verbose}, ' // & '\ttt{?vamp\_verbose})')) call var_list%append_log (var_str ("?vamp_history_global_verbose"), & .false., intrinsic=.true., & description=var_str ('Flag that decides whether the global history ' // & 'of the grid adaptation of the \vamp\ integrator are written ' // & 'into the process logfiles in an extended version. Only for debugging ' // & 'purposes. (cf. also \ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_channels}, ' // & '\ttt{?vamp\_verbose}, \ttt{?vamp\_history\_channels\_verbose})')) call var_list%append_log (var_str ("?vamp_history_channels"), & .false., intrinsic=.true., & description=var_str ('Flag that decides whether the history of ' // & 'the grid adaptation of the \vamp\ integrator for every single ' // & 'channel are written into the process logfiles. Only for debugging ' // & 'purposes. (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // & '\ttt{?vamp\_history\_global}, \ttt{?vamp\_verbose}, \newline ' // & '\ttt{?vamp\_history\_channels\_verbose})')) call var_list%append_log (var_str ("?vamp_history_channels_verbose"), & .false., intrinsic=.true., & description=var_str ('Flag that decides whether the history of ' // & 'the grid adaptation of the \vamp\ integrator for every single ' // & 'channel are written into the process logfiles in an extended ' // & 'version. Only for debugging purposes. (cf. also \ttt{?vamp\_history\_global}, ' // & '\ttt{?vamp\_history\_channels}, \ttt{?vamp\_verbose}, \ttt{?vamp\_history\_global\_verbose})')) call var_list%append_string (var_str ("$run_id"), var_str (""), & intrinsic=.true., & description=var_str ('String variable \ttt{\$run\_id = "{\em ' // & '}"} that allows to set a special ID for a particular process ' // & 'run, e.g. in a scan. The run ID is then attached to the process ' // & 'log file: \newline \ttt{{\em }\_{\em }.{\em ' // & '}.log}, the \vamp\ grid file: \newline \ttt{{\em }\_{\em ' // & '}.{\em }.vg}, and the phase space file: \newline ' // & '\ttt{{\em }\_{\em }.{\em }.phs}. ' // & 'The run ID string distinguishes among several runs for the ' // & 'same process. It identifies process instances with respect ' // & 'to adapted integration grids and similar run-specific data. ' // & 'The run ID is kept when copying processes for creating instances, ' // & 'however, so it does not distinguish event samples. (cf.\ also ' // & '\ttt{\$job\_id}, \ttt{\$compile\_workspace}')) call var_list%append_int (var_str ("n_calls_test"), 0, & intrinsic=.true., & description=var_str ('Integer variable that allows to set a ' // & 'certain number of matrix element sampling test calls without ' // & 'actually integrating the process under consideration. (cf. ' // & '\ttt{integrate})')) call var_list%append_log (var_str ("?integration_timer"), .true., & intrinsic=.true., & description=var_str ('This flag switches the integration timer ' // & 'on and off, that gives the estimate for the duration of the ' // & 'generation of 10,000 unweighted events for each integrated ' // & 'process.')) call var_list%append_log (var_str ("?check_grid_file"), .true., & intrinsic=.true., & description=var_str ('Setting this to false turns off all sanity ' // & 'checks when reading a grid file with previous integration data. ' // & 'Use this at your own risk; the program may return wrong results ' // & 'or crash if data do not match. (cf. also \ttt{?check\_event\_file}, \ttt{?check\_phs\_file}) ')) call var_list%append_real (var_str ("accuracy_goal"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that allows the user to ' // & 'set a minimal accuracy that should be achieved in the Monte-Carlo ' // & 'integration of a certain process. If that goal is reached, ' // & 'grid and weight adapation stop, and this result is used for ' // & 'simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // & '\ttt{error\_goal}, \ttt{relative\_error\_goal}, ' // & '\ttt{error\_threshold})')) call var_list%append_real (var_str ("error_goal"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that allows the user to ' // & 'set a minimal absolute error that should be achieved in the ' // & 'Monte-Carlo integration of a certain process. If that goal ' // & 'is reached, grid and weight adapation stop, and this result ' // & 'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // & '\ttt{accuracy\_goal}, \ttt{relative\_error\_goal}, \ttt{error\_threshold})')) call var_list%append_real (var_str ("relative_error_goal"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that allows the user to ' // & 'set a minimal relative error that should be achieved in the ' // & 'Monte-Carlo integration of a certain process. If that goal ' // & 'is reached, grid and weight adaptation stop, and this result ' // & 'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // & '\ttt{accuracy\_goal}, \ttt{error\_goal}, \ttt{error\_threshold})')) call var_list%append_int (var_str ("integration_results_verbosity"), 1, & intrinsic=.true., & description=var_str ('Integer parameter for the verbosity of ' // & 'the integration results in the process-specific logfile.')) call var_list%append_real (var_str ("error_threshold"), & 0._default, intrinsic=.true., & description=var_str ('The real parameter \ttt{error\_threshold ' // & '= {\em }} declares that any error value (in absolute numbers) ' // & 'smaller than \ttt{{\em }} is to be considered zero. The ' // & 'units are \ttt{fb} for scatterings and \ttt{GeV} for decays. ' // & '(cf. also \ttt{integrate}, \ttt{iterations}, \ttt{accuracy\_goal}, ' // & '\ttt{error\_goal}, \ttt{relative\_error\_goal})')) call var_list%append_real (var_str ("channel_weights_power"), 0.25_default, & intrinsic=.true., & description=var_str ('Real parameter that allows to vary the ' // & 'exponent of the channel weights for the \vamp\ integrator.')) call var_list%append_string (var_str ("$integrate_workspace"), & intrinsic=.true., & description=var_str ('Character string that tells \whizard\ ' // & 'the subdirectory where to find the run-specific phase-space ' // & 'configuration and the \vamp\ and \vamptwo\ grid files. ' // & 'If undefined (as per default), \whizard\ creates them and ' // & 'searches for them in the ' // & 'current directory. (cf. also \ttt{\$job\_id}, ' // & '\ttt{\$run\_id}, \ttt{\$compile\_workspace})')) call var_list%append_int (var_str ("vamp_grid_checkpoint"), 1, & intrinsic=.true., & description=var_str ('Integer parameter for setting checkpoints to save ' // & 'the current state of the grids and the results so far of the integration. ' // & 'Allowed are all positive integer. Zero values corresponds to a checkpoint ' // & 'after each integration pass, a one value to a checkpoint after each iteration ' // & '(default) and an \(N\) value correspond to a checkpoint after \(N\) iterations ' // & ' or after each pass, respectively.')) call var_list%append_string (var_str ("$vamp_grid_format"), var_str ("ascii"), & intrinsic=.true., & description=var_str ('Character string that tells \whizard\ ' // & 'the file format for \ttt{vamp2} to use for writing and reading ' // & 'the configuration for the multi-channel integration setup and the ' // & '\vamptwo\ (only) grid data. The values can be \ttt{ascii} for a single ' // & 'human-readable grid file with ending \ttt{.vg2} or \ttt{binary} for two files, ' // & 'a human-readable header file with ending \ttt{.vg2} and binary file with ending ' // & '\ttt{.vgx2} storing the grid data.' // & 'The main purpose of the binary format is to perform faster I/O, e.g. for HPC runs.' // & '\whizard\ can convert between the different file formats automatically.')) call var_list%append_string (var_str ("$vamp_parallel_method"), var_str ("simple"), & intrinsic=.true., & description=var_str ('Character string that tells \whizard\ ' // & 'the parallel method to use for parallel integration within \ttt{vamp2}.' // & ' (i) \ttt{simple} (default) is a local work sharing approach without the need of communication ' // & 'between all workers except for the communication during result collection.' // & ' (ii) \ttt{load} is a global queue approach where the master worker acts as a' // & 'governor listening and providing work for each worker. The queue is filled and assigned with workers ' // & 'a-priori with respect to the assumed computational impact of each channel.' // & 'Both approaches use the same mechanism for result collection using non-blocking ' // & 'communication allowing for a efficient usage of the computing resources.')) end subroutine var_list_set_integration_defaults @ %def var_list_set_integration_defaults @ <>= procedure :: set_phase_space_defaults => var_list_set_phase_space_defaults <>= subroutine var_list_set_phase_space_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$phs_method"), var_str ("default"), & intrinsic=.true., & description=var_str ('String variable that allows to choose ' // & 'the phase-space parameterization method. The default is the ' // & '\ttt{"wood"} method that takes into account electroweak/BSM ' // & 'resonances. Note that this might not be the best choice for ' // & '(pure) QCD amplitudes. (cf. also \ttt{\$phs\_file})')) call var_list%append_log (var_str ("?vis_channels"), .false., & intrinsic=.true., & description=var_str ('Optional logical argument for the \ttt{integrate} ' // & 'command that demands \whizard\ to generate a PDF or postscript ' // & 'output showing the classification of the found phase space ' // & 'channels (if the phase space method \ttt{wood} has been used) ' // & 'according to their properties: \ttt{integrate (foo) \{ iterations=3:10000 ' // & '?vis\_channels = true \}}. The default is \ttt{false}. (cf. ' // & 'also \ttt{integrate}, \ttt{?vis\_history})')) call var_list%append_log (var_str ("?check_phs_file"), .true., & intrinsic=.true., & description=var_str ('Setting this to false turns off all sanity ' // & 'checks when reading a previously generated phase-space configuration ' // & 'file. Use this at your own risk; the program may return wrong ' // & 'results or crash if data do not match. (cf. also \ttt{?check\_event\_file}, ' // & '\ttt{?check\_grid\_file})')) call var_list%append_string (var_str ("$phs_file"), var_str (""), & intrinsic=.true., & description=var_str ('This string variable allows the user to ' // & 'set an individual file name for the phase space parameterization ' // & 'for a particular process: \ttt{\$phs\_file = "{\em }"}. ' // & 'If not set, the default is \ttt{{\em }\_{\em }.{\em ' // & '}.phs}. (cf. also \ttt{\$phs\_method})')) call var_list%append_log (var_str ("?phs_only"), .false., & intrinsic=.true., & description=var_str ('Flag (particularly as optional argument ' // & 'of the $\to$ \ttt{integrate} command) that allows to only generate ' // & 'the phase space file, but not perform the integration. (cf. ' // & 'also \ttt{\$phs\_method}, \ttt{\$phs\_file})')) call var_list%append_real (var_str ("phs_threshold_s"), 50._default, & intrinsic=.true., & description=var_str ('For the phase space method \ttt{wood}, ' // & 'this real parameter sets the threshold below which particles ' // & 'are assumed to be massless in the $s$-channel like kinematic ' // & 'regions. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_off\_shell}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // & '\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_threshold_t"), 100._default, & intrinsic=.true., & description=var_str ('For the phase space method \ttt{wood}, ' // & 'this real parameter sets the threshold below which particles ' // & 'are assumed to be massless in the $t$-channel like kinematic ' // & 'regions. (cf. also \ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // & '\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})')) call var_list%append_int (var_str ("phs_off_shell"), 2, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of off-shell (not $t$-channel-like, non-resonant) lines that ' // & 'are taken into account to find a valid phase-space setup in ' // & 'the \ttt{wood} phase-space method. (cf. also \ttt{phs\_threshold\_t}, ' // & '\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // & '\ttt{?phs\_s\_mapping})')) call var_list%append_int (var_str ("phs_t_channel"), 6, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of $t$-channel propagators in multi-peripheral diagrams that ' // & 'are taken into account to find a valid phase-space setup in ' // & 'the \ttt{wood} phase-space method. (cf. also \ttt{phs\_threshold\_t}, ' // & '\ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // & '\ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_e_scale"), 10._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the energy scale ' // & 'that acts as a cutoff for parameterizing radiation-like kinematics ' // & 'in the \ttt{wood} phase space method. \whizard\ takes the maximum ' // & 'of this value and the width of the propagating particle as ' // & 'a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // & '\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_m_scale"), 10._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the mass scale ' // & 'that acts as a cutoff for parameterizing collinear and infrared ' // & 'kinematics in the \ttt{wood} phase space method. \whizard\ ' // & 'takes the maximum of this value and the mass of the propagating ' // & 'particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_q_scale"), 10._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the momentum ' // & 'transfer scale that acts as a cutoff for parameterizing $t$- ' // & 'and $u$-channel like kinematics in the \ttt{wood} phase space ' // & 'method. \whizard\ takes the maximum of this value and the mass ' // & 'of the propagating particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, ' // & '\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, ' // & '\ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp}, ' // & '\newline \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_keep_nonresonant"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether the \ttt{wood} ' // & 'phase space method takes into account also non-resonant contributions. ' // & '(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // & '\ttt{phs\_q\_scale}, \ttt{phs\_e\_scale}, \ttt{?phs\_step\_mapping}, ' // & '\newline \ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_step_mapping"), .true., & intrinsic=.true., & description=var_str ('Flag that switches on (or off) a particular ' // & 'phase space mapping for resonances, where the mass and width ' // & 'of the resonance are explicitly set as channel cutoffs. (cf. ' // & 'also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, ' // & '\ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, \newline \ttt{phs\_m\_scale}, ' // & '\ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, \ttt{?phs\_step\_mapping\_exp}, ' // & '\newline \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_step_mapping_exp"), .true., & intrinsic=.true., & description=var_str ('Flag that switches on (or off) a particular ' // & 'phase space mapping for resonances, where the mass and width ' // & 'of the resonance are explicitly set as channel cutoffs. This ' // & 'is an exponential mapping in contrast to ($\to$) \ttt{?phs\_step\_mapping}. ' // & '(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \newline \ttt{?phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_s_mapping"), .true., & intrinsic=.true., & description=var_str ('Flag that allows special mapping for $s$-channel ' // & 'resonances. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, ' // & '\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp})')) call var_list%append_log (var_str ("?vis_history"), .false., & intrinsic=.true., & description=var_str ('Optional logical argument for the \ttt{integrate} ' // & 'command that demands \whizard\ to generate a PDF or postscript ' // & 'output showing the adaptation history of the Monte-Carlo integration ' // & 'of the process under consideration. (cf. also \ttt{integrate}, ' // & '\ttt{?vis\_channels})')) end subroutine var_list_set_phase_space_defaults @ %def var_list_set_phase_space_defaults @ <>= procedure :: set_gamelan_defaults => var_list_set_gamelan_defaults <>= subroutine var_list_set_gamelan_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_int (& var_str ("n_bins"), 20, & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: integer value that sets the number of bins in histograms. ' // & '(cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // & '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // & '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, ' // & '\ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (& var_str ("?normalize_bins"), .false., & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that determines whether the weights shall be normalized ' // & 'to the bin width or not. (cf. also \ttt{n\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\newline \ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \newline ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options})')) call var_list%append_string (var_str ("$obs_label"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: this is a string variable \ttt{\$obs\_label = "{\em ' // & '}"} that allows to attach a label to a plotted ' // & 'or histogrammed observable. (cf. also \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$obs_unit"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: this is a string variable \ttt{\$obs\_unit = "{\em ' // & '}"} that allows to attach a \LaTeX\ physical unit ' // & 'to a plotted or histogrammed observable. (cf. also \ttt{n\_bins}, ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$title"), var_str (""), & intrinsic=.true., & description=var_str ('This string variable sets the title of ' // & 'a plot in a \whizard\ analysis setup, e.g. a histogram or an ' // & 'observable. The syntax is \ttt{\$title = "{\em }"}. ' // & 'This title appears as a section header in the analysis file, ' // & 'but not in the screen output of the analysis. (cf. also \ttt{n\_bins}, ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \newline \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$description"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to specify ' // & 'a description text for the analysis, \ttt{\$description = "{\em ' // & '}"}. This line appears below the title ' // & 'of a corresponding analysis, on top of the respective plot. ' // & '(cf. also \ttt{analysis}, \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_unit}, \ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, ' // & '\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$x_label"), var_str (""), & intrinsic=.true., & description=var_str ('String variable, \ttt{\$x\_label = "{\em ' // & '}"}, that sets the $x$ axis label in a plot or ' // & 'histogram in a \whizard\ analysis. (cf. also \ttt{analysis}, ' // & '\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$y\_label}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$y_label"), var_str (""), & intrinsic=.true., & description=var_str ('String variable, \ttt{\$y\_label = "{\em ' // & '}"}, that sets the $y$ axis label in a plot or ' // & 'histogram in a \whizard\ analysis. (cf. also \ttt{analysis}, ' // & '\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{?y\_log}, ' // & '\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_int (var_str ("graph_width_mm"), 130, & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: integer value that sets the width of a graph or histogram ' // & 'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // & '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_int (var_str ("graph_height_mm"), 90, & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: integer value that sets the height of a graph or histogram ' // & 'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // & '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?y_log"), .false., & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that makes the $y$ axis logarithmic. (cf. also ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // & '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // & '\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (var_str ("?x_log"), .false., & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that makes the $x$ axis logarithmic. (cf. also ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // & '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // & '\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_real (var_str ("x_min"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the lower limit of the $x$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_real (var_str ("x_max"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the upper limit of the $x$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_min}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_real (var_str ("y_min"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the lower limit of the $y$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_max}, \ttt{y\_max}, \ttt{x\_min}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_real (var_str ("y_max"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the upper limit of the $y$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_max}, \ttt{x\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$gmlcode_bg"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: string variable that allows to define a background ' // & 'for plots and histograms (i.e. it is overwritten by the plot/histogram), ' // & 'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // & 'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$gmlcode_fg"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: string variable that allows to define a foreground ' // & 'for plots and histograms (i.e. it overwrites the plot/histogram), ' // & 'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // & 'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_histogram"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to either plot data as a ' // & 'histogram or as a continuous line (if $\to$ \ttt{?draw\_curve} ' // & 'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_base"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to insert a \ttt{base} statement ' // & 'in the analysis code to calculate the plot data from a data ' // & 'set. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{\$symbol}, \newline \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\newline \ttt{\$err\_options})')) call var_list%append_log (var_str ("?draw_piecewise"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to data from a data set piecewise, ' // & 'i.e. histogram style. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, ' // & '\ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_base}, \ttt{?fill\_curve}, ' // & '\ttt{\$symbol}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options})')) call var_list%append_log (var_str ("?fill_curve"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to fill data curves (e.g. ' // & 'as a histogram). The style can be set with $\to$ \ttt{\$fill\_options ' // & '= "{\em }"}. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_curve"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to either plot data as a ' // & 'continuous line or as a histogram (if $\to$ \ttt{?draw\_histogram} ' // & 'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_errors"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that determines whether error bars should be drawn ' // & 'or not. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\newline \ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_symbols"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that determines whether particular symbols (specified ' // & 'by $\to$ \ttt{\$symbol = "{\em }"}) should be ' // & 'used for plotting data points (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\newline \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$fill_options"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$fill\_options = "{\em }"} is a ' // & 'string variable that allows to set fill options when plotting ' // & 'data as filled curves with the $\to$ \ttt{?fill\_curve} flag. ' // & 'For more details see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\newline \ttt{?draw\_symbols}, \ttt{?fill\_curve}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$draw_options"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$draw\_options = "{\em }"} is a ' // & 'string variable that allows to set specific drawing options ' // & 'for plots and histograms. For more details see the \gamelan\ ' // & 'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // & '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // & '\ttt{?draw\_histogram}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$err_options"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$err\_options = "{\em }"} is a string ' // & 'variable that allows to set specific drawing options for errors ' // & 'in plots and histograms. For more details see the \gamelan\ ' // & 'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{?draw\_histogram}, \ttt{\$draw\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$symbol"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$symbol = "{\em }"} is a string ' // & 'variable for the symbols that should be used for plotting data ' // & 'points. (cf. also \ttt{\$obs\_label}, \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \newline \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\newline \ttt{?draw\_histogram}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \newline \ttt{\$err\_options}, ' // & '\ttt{?draw\_symbols})')) call var_list%append_log (& var_str ("?analysis_file_only"), .false., & intrinsic=.true., & description=var_str ('Allows to specify that only \LaTeX\ files ' // & "for \whizard's graphical analysis are written out, but not processed. " // & '(cf. \ttt{compile\_analysis}, \ttt{write\_analysis})')) end subroutine var_list_set_gamelan_defaults @ %def var_list_set_gamelan_defaults @ FastJet parameters and friends <>= procedure :: set_clustering_defaults => var_list_set_clustering_defaults <>= subroutine var_list_set_clustering_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_int (& var_str ("kt_algorithm"), & kt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the ' // & 'interfaced external \fastjet\ package. (cf. also ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, ' // & '\ttt{plugin\_algorithm}, ' // & '\newline\ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})')) call var_list%append_int (& var_str ("cambridge_algorithm"), & cambridge_algorithm, intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("antikt_algorithm"), & antikt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("genkt_algorithm"), & genkt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_for\_passive\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r}), \ttt{jet\_p}')) call var_list%append_int (& var_str ("cambridge_for_passive_algorithm"), & cambridge_for_passive_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_algorithm}, \ttt{plugin\_algorithm}, \newline ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("genkt_for_passive_algorithm"), & genkt_for_passive_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})')) call var_list%append_int (& var_str ("ee_kt_algorithm"), & ee_kt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_genkt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("ee_genkt_algorithm"), & ee_genkt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_kt\_algorithm}, ' // & '\ttt{jet\_r}), \ttt{jet\_p})')) call var_list%append_int (& var_str ("plugin_algorithm"), & plugin_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("undefined_jet_algorithm"), & undefined_jet_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('This is just a place holder for any kind of jet ' // & 'jet algorithm that is not further specified. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r}, \ttt{plugin\_algorithm})')) call var_list%append_int (& var_str ("jet_algorithm"), undefined_jet_algorithm, & intrinsic = .true., & description=var_str ('Variable that allows to set the type of ' // & 'jet algorithm when using the external \fastjet\ library. It ' // & 'accepts one of the following algorithms: ($\to$) \ttt{kt\_algorithm}, ' // & '\newline ($\to$) \ttt{cambridge\_[for\_passive\_]algorithm}, ' // & '($\to$) \ttt{antikt\_algorithm}, ($\to$) \ttt{plugin\_algorithm}, ' // & '($\to$) \ttt{genkt\_[for\_passive\_]algorithm}, ($\to$) ' // & '\ttt{ee\_[gen]kt\_algorithm}). (cf. also \ttt{cluster}, ' // & '\ttt{jet\_p}, \ttt{jet\_r}, \ttt{jet\_ycut})')) call var_list%append_real (& var_str ("jet_r"), 0._default, & intrinsic = .true., & description=var_str ('Value for the distance measure $R$ used in ' // & 'some algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_ycut})')) call var_list%append_real (& var_str ("jet_p"), 0._default, & intrinsic = .true., & description=var_str ('Value for the exponent of the distance measure $R$ in ' // & 'the generalized $k_T$ algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r}, \newline\ttt{jet\_ycut})')) call var_list%append_real (& var_str ("jet_ycut"), 0._default, & intrinsic = .true., & description=var_str ('Value for the $y$ separation measure used in ' // & 'the Cambridge-Aachen algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})')) call var_list%append_real (& var_str ("jet_dcut"), 0._default, & intrinsic = .true., & description=var_str ('Value for the $d_{ij}$ separation measure used in ' // & 'the $e^+e^- k_T$ algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})')) call var_list%append_log (& var_str ("?keep_flavors_when_clustering"), .false., & intrinsic = .true., & description=var_str ('The logical variable \ttt{?keep\_flavors\_when\_clustering ' // & '= true/false} specifies whether the flavor of a jet should be ' // & 'kept during \ttt{cluster} when a jet consists of one quark and ' // & 'zero or more gluons. Especially useful for cuts on b-tagged ' // & 'jets (cf. also \ttt{cluster}).')) end subroutine var_list_set_clustering_defaults @ %def var_list_set_clustering_defaults @ Frixione isolation and photon recombination parameters and all that: <>= procedure :: set_isolation_recomb_defaults => & var_list_set_isolation_recomb_defaults <>= subroutine var_list_set_isolation_recomb_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_real (var_str ("photon_iso_eps"), 1._default, & intrinsic=.true., & description=var_str ('Photon isolation parameter $\epsilon_\gamma$ ' // & '(energy fraction) from hep-ph/9801442 (cf. also ' // & '\ttt{photon\_iso\_n}, \ttt{photon\_iso\_r0})')) call var_list%append_real (var_str ("photon_iso_n"), 1._default, & intrinsic=.true., & description=var_str ('Photon isolation parameter $n$ ' // & '(cone function exponent) from hep-ph/9801442 (cf. also ' // & '\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_r0})')) call var_list%append_real (var_str ("photon_iso_r0"), 0.4_default, & intrinsic=.true., & description=var_str ('Photon isolation parameter $R_0^\gamma$ ' // & '(isolation cone radius) from hep-ph/9801442 (cf. also ' // & '\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_n})')) call var_list%append_real (var_str ("photon_rec_r0"), 0.1_default, & intrinsic=.true., & description=var_str ('Photon recombination parameter $R_0^\gamma$ ' // & 'for photon recombination in NLO EW calculations')) call var_list%append_log (& var_str ("?keep_flavors_when_recombining"), .true., & intrinsic = .true., & description=var_str ('The logical variable \ttt{?keep\_flavors\_when\_recombining ' // & '= true/false} specifies whether the flavor of a particle should be ' // & 'kept during \ttt{photon\_recombination} when a jet/lepton consists of one lepton/quark ' // & 'and zero or more photons (cf. also \ttt{photon\_recombination}).')) end subroutine var_list_set_isolation_recomb_defaults @ %def var_list_set_isolation_recomb_defaults <>= procedure :: set_eio_defaults => var_list_set_eio_defaults <>= subroutine var_list_set_eio_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$sample"), var_str (""), & intrinsic=.true., & description=var_str ('String variable to set the (base) name ' // & 'of the event output format, e.g. \ttt{\$sample = "foo"} will ' // & 'result in an intrinsic binary format event file \ttt{foo.evx}. ' // & '(cf. also \ttt{sample\_format}, \ttt{simulate}, \ttt{hepevt}, ' // & '\ttt{ascii}, \ttt{athena}, \ttt{debug}, \ttt{long}, \ttt{short}, ' // & '\ttt{hepmc}, \ttt{lhef}, \ttt{lha}, \ttt{stdhep}, \ttt{stdhep\_up}, ' // & '\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, \ttt{sample\_max\_tries})')) call var_list%append_string (var_str ("$sample_normalization"), var_str ("auto"),& intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'normalization of generated events. There are four options: ' // & 'option \ttt{"1"} (events normalized to one), \ttt{"1/n"} (sum ' // & 'of all events in a sample normalized to one), \ttt{"sigma"} ' // & '(events normalized to the cross section of the process), and ' // & '\ttt{"sigma/n"} (sum of all events normalized to the cross ' // & 'section). The default is \ttt{"auto"} where unweighted events ' // & 'are normalized to one, and weighted ones to the cross section. ' // & '(cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?sample\_pacify}, \ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // & '\ttt{sample\_split\_n\_kbytes})')) call var_list%append_log (var_str ("?sample_pacify"), .false., & intrinsic=.true., & description=var_str ('Flag, mainly for debugging purposes: suppresses ' // & 'numerical noise in the output of a simulation. (cf. also \ttt{simulate}, ' // & '\ttt{\$sample}, \ttt{sample\_format}, \ttt{\$sample\_normalization}, ' // & '\ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // & '\ttt{sample\_split\_n\_kbytes})')) call var_list%append_log (var_str ("?sample_select"), .true., & intrinsic=.true., & description=var_str ('Logical that determines whether a selection should ' // & 'be applied to the output event format or not. If set to \ttt{false} a ' // & 'selection is only considered for the evaluation of observables. (cf. ' // & '\ttt{select}, \ttt{selection}, \ttt{analysis})')) call var_list%append_int (var_str ("sample_max_tries"), 10000, & intrinsic = .true., & description=var_str ('Integer variable that sets the maximal ' // & 'number of tries for generating a single event. The event might ' // & 'be vetoed because of a very low unweighting efficiency, errors ' // & 'in the event transforms like decays, shower, matching, hadronization ' // & 'etc. (cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?sample\_pacify}, \ttt{\$sample\_normalization}, ' // & '\ttt{sample\_split\_n\_evt}, \newline\ttt{sample\_split\_n\_kbytes})')) call var_list%append_int (var_str ("sample_split_n_evt"), 0, & intrinsic = .true., & description=var_str ('When generating events, this integer parameter ' // & '\ttt{sample\_split\_n\_evt = {\em }} gives the number \ttt{{\em ' // & '}} of breakpoints in the event files, i.e. it splits the ' // & 'event files into \ttt{{\em } + 1} parts. The parts are ' // & 'denoted by \ttt{{\em }.{\em }.{\em ' // & '}}. Here, \ttt{{\em }} is an integer ' // & 'running from \ttt{0} to \ttt{{\em }}. The start can be ' // & 'reset by ($\to$) \ttt{sample\_split\_index}. (cf. also \ttt{simulate}, ' // & '\ttt{\$sample}, \ttt{sample\_format}, \ttt{sample\_max\_tries}, ' // & '\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, ' // & '\ttt{sample\_split\_n\_kbytes})')) call var_list%append_int (var_str ("sample_split_n_kbytes"), 0, & intrinsic = .true., & description=var_str ('When generating events, this integer parameter ' // & '\ttt{sample\_split\_n\_kbytes = {\em }} limits the file ' // & 'size of event files. Whenever an event file has exceeded this ' // & 'size, counted in kilobytes, the following events will be written ' // & 'to a new file. The naming conventions are the same as for ' // & '\ttt{sample\_split\_n\_evt}. (cf. also \ttt{simulate}, \ttt{\$sample}, ' // & '\ttt{sample\_format}, \ttt{sample\_max\_tries}, \ttt{\$sample\_normalization}, ' // & '\ttt{?sample\_pacify})')) call var_list%append_int (var_str ("sample_split_index"), 0, & intrinsic = .true., & description=var_str ('Integer number that gives the starting ' // & 'index \ttt{sample\_split\_index = {\em }} for ' // & 'the numbering of event samples \ttt{{\em }.{\em ' // & '}.{\em }} split by the \ttt{sample\_split\_n\_evt ' // & '= {\em }}. The index runs from \ttt{{\em }} ' // & 'to \newline \ttt{{\em } + {\em }}. (cf. also \ttt{simulate}, ' // & '\ttt{\$sample}, \ttt{sample\_format}, \newline\ttt{\$sample\_normalization}, ' // & '\ttt{sample\_max\_tries}, \ttt{?sample\_pacify})')) call var_list%append_string (var_str ("$rescan_input_format"), var_str ("raw"), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'event format of the event file that is to be rescanned by the ' // & '($\to$) \ttt{rescan} command.')) call var_list%append_log (var_str ("?read_raw"), .true., & intrinsic=.true., & description=var_str ('This flag demands \whizard\ to (try to) ' // & 'read events (from the internal binary format) first before ' // & 'generating new ones. (cf. \ttt{simulate}, \ttt{?write\_raw}, ' // & '\ttt{\$sample}, \ttt{sample\_format})')) call var_list%append_log (var_str ("?write_raw"), .true., & intrinsic=.true., & description=var_str ("Flag to write out events in \whizard's " // & 'internal binary format. (cf. \ttt{simulate}, \ttt{?read\_raw}, ' // & '\ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_raw"), var_str ("evx"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_raw ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & "to which events in \whizard's internal format are written. If " // & 'not set, the default file name and suffix is \ttt{{\em }.evx}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_default"), var_str ("evt"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_default ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in a the standard \whizard\ verbose ASCII format ' // & 'are written. If not set, the default file name and suffix is ' // & '\ttt{{\em }.evt}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) call var_list%append_string (var_str ("$debug_extension"), var_str ("debug"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$debug\_extension ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in a long verbose format with debugging information ' // & 'are written. If not set, the default file name and suffix is ' // & '\ttt{{\em }.debug}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{?debug\_process}, \ttt{?debug\_transforms}, ' // & '\ttt{?debug\_decay}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_process"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether process information ' // & 'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // & '\ttt{?debug\_decay}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_transforms"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether information ' // & 'about event transforms will be displayed in the ASCII debug ' // & 'event format ($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{?debug\_decay}, \ttt{\$debug\_extension}, ' // & '\ttt{?debug\_process}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_decay"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether decay information ' // & 'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // & '\ttt{?debug\_process}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_verbose"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether extensive verbose ' // & 'information will be included in the ASCII debug event format ' // & '($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, \ttt{\$sample}, ' // & '\ttt{\$debug\_extension}, \ttt{?debug\_decay}, \ttt{?debug\_transforms}, ' // & '\ttt{?debug\_process})')) call var_list%append_string (var_str ("$dump_extension"), var_str ("pset.dat"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$dump\_extension ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & "to which events in \whizard's internal particle set format " // & 'are written. If not set, the default file name and suffix is ' // & '\ttt{{\em }.pset.dat}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?dump_compressed"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, issues ' // & 'a very compressed and clear version of the \ttt{dump} ($\to$) ' // & 'event format. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{\$dump\_extension}, ' // & '\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?dump_weights"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, includes ' // & 'cross sections, weights and excess in the \ttt{dump} ($\to$) ' // & 'event format. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_summary})')) call var_list%append_log (var_str ("?dump_summary"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, includes ' // & 'a summary with momentum sums for incoming and outgoing particles ' // & 'as well as for beam remnants in the \ttt{dump} ($\to$) ' // & 'event format. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?dump_screen"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, outputs ' // & 'events for the \ttt{dump} ($\to$) event format on screen ' // & ' instead of to a file. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{\$dump\_extension}, \ttt{?dump\_summary}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?hepevt_ensure_order"), .false., & intrinsic=.true., & description=var_str ('Flag to ensure that the particle set confirms ' // & 'the HEPEVT standard. This involves some copying and reordering ' // & 'to guarantee that mothers and daughters are always next to ' // & 'each other. Usually this is not necessary.')) call var_list%append_string (var_str ("$extension_hepevt"), var_str ("hepevt"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_hepevt ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the \whizard\ version 1 style HEPEVT ASCII ' // & 'format are written. If not set, the default file name and suffix ' // & 'is \ttt{{\em }.hepevt}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) call var_list%append_string (var_str ("$extension_ascii_short"), & var_str ("short.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_short ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the so called short variant of the \whizard\ ' // & 'version 1 style HEPEVT ASCII format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.short.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_ascii_long"), & var_str ("long.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_long ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the so called long variant of the \whizard\ ' // & 'version 1 style HEPEVT ASCII format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.long.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_athena"), & var_str ("athena.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_athena ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the ATHENA file format are written. If not ' // & 'set, the default file name and suffix is \ttt{{\em }.athena.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_mokka"), & var_str ("mokka.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_mokka ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the MOKKA format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.mokka.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$lhef_version"), var_str ("2.0"), & intrinsic = .true., & description=var_str ('Specifier for the Les Houches Accord (LHEF) ' // & 'event format files with XML headers to discriminate among different ' // & 'versions of this format. (cf. also \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // & '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref}, ' // & '\ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_string (var_str ("$lhef_extension"), var_str ("lhe"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$lhef\_extension ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the LHEF format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.lhe}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{lhef}, ' // & '\ttt{\$lhef\_extension}, \ttt{\$lhef\_version}, \ttt{?lhef\_write\_sqme\_prc}, ' // & '\ttt{?lhef\_write\_sqme\_ref}, \ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_log (var_str ("?lhef_write_sqme_prc"), .true., & intrinsic = .true., & description=var_str ('Flag that decides whether in the ($\to$) ' // & '\ttt{lhef} event format the weights of the squared matrix element ' // & 'of the corresponding process shall be written in the LHE file. ' // & '(cf. also \ttt{\$sample}, \ttt{sample\_format}, \ttt{lhef}, ' // & '\ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, \ttt{?lhef\_write\_sqme\_ref}, ' // & '\newline \ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_log (var_str ("?lhef_write_sqme_ref"), .false., & intrinsic = .true., & description=var_str ('Flag that decides whether in the ($\to$) ' // & '\ttt{lhef} event format reference weights of the squared matrix ' // & 'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // & '\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // & '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_log (var_str ("?lhef_write_sqme_alt"), .true., & intrinsic = .true., & description=var_str ('Flag that decides whether in the ($\to$) ' // & '\ttt{lhef} event format alternative weights of the squared matrix ' // & 'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // & '\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // & '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref})')) call var_list%append_string (var_str ("$extension_lha"), var_str ("lha"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_lha ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the (deprecated) LHA format are written. ' // & 'If not set, the default file name and suffix is \ttt{{\em }.lha}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_hepmc"), var_str ("hepmc"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_hepmc ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the HepMC format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.hepmc}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_log (var_str ("?hepmc_output_cross_section"), .false., & intrinsic = .true., & description=var_str ('Flag for the HepMC event format that allows ' // & 'to write out the cross section (and error) from the integration ' // & 'together with each HepMC event. This can be used by programs ' // & 'like Rivet to scale histograms according to the cross section. ' // & '(cf. also \ttt{hepmc})')) call var_list%append_log (var_str ("?hepmc3_write_flows"), .false., & intrinsic = .true., & description=var_str ('Flag for the HepMC3 event format that decides' // & 'whether to write out color flows. The default is \ttt{false}. ' // & '(cf. also \ttt{hepmc})')) call var_list%append_string (var_str ("$hepmc3_mode"), var_str ("HepMC3"), & intrinsic = .true., & description=var_str ('This specifies the writer mode for HepMC3. ' // & 'Possible values are \ttt{HepMC2}, \ttt{HepMC3} (default), ' // & '\ttt{HepEVT}, \ttt{Root}. and \ttt{RootTree} (cf. also \ttt{hepmc})')) call var_list%append_string (var_str ("$extension_lcio"), var_str ("slcio"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_lcio ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the LCIO format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.slcio}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_stdhep"), var_str ("hep"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_stdhep ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the StdHEP format via the HEPEVT common ' // & 'block are written. If not set, the default file name and suffix ' // & 'is \ttt{{\em }.hep}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) call var_list%append_string (var_str ("$extension_stdhep_up"), & var_str ("up.hep"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_up ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the StdHEP format via the HEPRUP/HEPEUP ' // & 'common blocks are written. \ttt{{\em }.up.hep} ' // & 'is the default file name and suffix, if this variable not set. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_stdhep_ev4"), & var_str ("ev4.hep"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_ev4 ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the StdHEP format via the HEPEVT/HEPEV4 ' // & 'common blocks are written. \ttt{{\em }.up.hep} ' // & 'is the default file name and suffix, if this variable not set. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_hepevt_verb"), & var_str ("hepevt.verb"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_hepevt\_verb ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the \whizard\ version 1 style extended or ' // & 'verbose HEPEVT ASCII format are written. If not set, the default ' // & 'file name and suffix is \ttt{{\em }.hepevt.verb}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_lha_verb"), & var_str ("lha.verb"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_lha\_verb ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the (deprecated) extended or verbose LHA ' // & 'format are written. If not set, the default file name and suffix ' // & 'is \ttt{{\em }.lha.verb}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) end subroutine var_list_set_eio_defaults @ %def var_list_set_eio_defaults @ <>= procedure :: set_shower_defaults => var_list_set_shower_defaults <>= subroutine var_list_set_shower_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?allow_shower"), .true., & intrinsic=.true., & description=var_str ('Master flag to switch on (initial and ' // & 'final state) parton shower, matching/merging as an event ' // & 'transform. As a default, it is switched on. (cf. also \ttt{?ps\_ ' // & '....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_fsr_active"), .false., & intrinsic=.true., & description=var_str ('Flag that switches final-state QCD radiation ' // & '(FSR) on. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_active"), .false., & intrinsic=.true., & description=var_str ('Flag that switches initial-state QCD ' // & 'radiation (ISR) on. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_taudec_active"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on $\tau$ decays, at ' // & 'the moment only via the included external package \ttt{TAUOLA} ' // & 'and \ttt{PHOTOS}. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?muli_active"), .false., & intrinsic=.true., & description=var_str ("Master flag that switches on \whizard's " // & 'module for multiple interaction with interleaved QCD parton ' // & 'showers for hadron colliders. Note that this feature is still ' // & 'experimental. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})')) call var_list%append_string (var_str ("$shower_method"), var_str ("WHIZARD"), & intrinsic=.true., & description=var_str ('String variable that allows to specify ' // & 'which parton shower is being used, the default, \ttt{"WHIZARD"}, ' // & 'is one of the in-house showers of \whizard. Other possibilities ' // & 'at the moment are only \ttt{"PYTHIA6"}.')) call var_list%append_log (var_str ("?shower_verbose"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on verbose messages when ' // & 'using shower and/or hadronization. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...},')) call var_list%append_string (var_str ("$ps_PYTHIA_PYGIVE"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass options ' // & 'for tunes etc. to the attached \pythia\ parton shower or hadronization, ' // & 'e.g.: \ttt{\$ps\_PYTHIA\_PYGIVE = "MSTJ(41)=1"}. (cf. also ' // & '\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_string (var_str ("$ps_PYTHIA8_config"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass options ' // & 'for tunes etc. to the attached \pythia\ttt{8} parton shower or hadronization, ' // & 'e.g.: \ttt{\$ps\_PYTHIA8\_config = "PartonLevel:MPI = off"}. (cf. also ' // & '\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_string (var_str ("$ps_PYTHIA8_config_file"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass a filename to a ' // & '\pythia\ttt{8} configuration file.')) call var_list%append_real (& var_str ("ps_mass_cutoff"), 1._default, intrinsic = .true., & description=var_str ('Real value that sets the QCD parton shower ' // & 'lower cutoff scale, where hadronization sets in. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (& var_str ("ps_fsr_lambda"), 0.29_default, intrinsic = .true., & description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // & 'used in running $\alpha_s$ for time-like showers is set (except ' // & 'for showers in the decay of a resonance). (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (& var_str ("ps_isr_lambda"), 0.29_default, intrinsic = .true., & description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // & 'used in running $\alpha_s$ for space-like showers is set. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_int (& var_str ("ps_max_n_flavors"), 5, intrinsic = .true., & description=var_str ('This integer parameter sets the maxmimum ' // & 'number of flavors that can be produced in a QCD shower $g\to ' // & 'q\bar q$. It is also used as the maximal number of active flavors ' // & 'for the running of $\alpha_s$ in the shower (with a minimum ' // & 'of 3). (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_alphas_running"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether a running ' // & '$\alpha_s$ is taken in space-like QCD parton showers. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_fsr_alphas_running"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether a running ' // & '$\alpha_s$ is taken in time-like QCD parton showers. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str ("ps_fixed_alphas"), & 0._default, intrinsic = .true., & description=var_str ('This real parameter sets the value of $\alpha_s$ ' // & 'if it is (cf. $\to$ \ttt{?ps\_isr\_alphas\_running}, \newline ' // & '\ttt{?ps\_fsr\_alphas\_running}) not running in initial and/or ' // & 'final-state QCD showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_pt_ordered"), .false., & intrinsic=.true., & description=var_str ('By this flag, it can be switched between ' // & 'the analytic QCD ISR shower (\ttt{false}, default) and the ' // & '$p_T$ ISR QCD shower (\ttt{true}). (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_angular_ordered"), .true., & intrinsic=.true., & description=var_str ('If switched one, this flag forces opening ' // & 'angles of emitted partons in the QCD ISR shower to be strictly ' // & 'ordered, i.e. increasing towards the hard interaction. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_primordial_kt_width"), 0._default, intrinsic = .true., & description=var_str ('This real parameter sets the width $\sigma ' // & '= \braket{k_T^2}$ for the Gaussian primordial $k_T$ distribution ' // & 'inside the hadron, given by: $\exp[-k_T^2/\sigma^2] k_T dk_T$. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_primordial_kt_cutoff"), 5._default, intrinsic = .true., & description=var_str ('Real parameter that sets the upper cutoff ' // & 'for the primordial $k_T$ distribution inside a hadron. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?hadronization\_active}, \ttt{?mlm\_ ...})')) call var_list%append_real (var_str & ("ps_isr_z_cutoff"), 0.999_default, intrinsic = .true., & description=var_str ('This real parameter allows to set the upper ' // & 'cutoff on the splitting variable $z$ in space-like QCD parton ' // & 'showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_minenergy"), 1._default, intrinsic = .true., & description=var_str ('By this real parameter, the minimal effective ' // & 'energy (in the c.m. frame) of a time-like or on-shell-emitted ' // & 'parton in a space-like QCD shower is set. For a hard subprocess ' // & 'that is not in the rest frame, this number is roughly reduced ' // & 'by a boost factor $1/\gamma$ to the rest frame of the hard scattering ' // & 'process. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_tscalefactor"), 1._default, intrinsic = .true., & description=var_str ('The $Q^2$ scale of the hard scattering ' // & 'process is multiplied by this real factor to define the maximum ' // & 'parton virtuality allowed in time-like QCD showers. This does ' // & 'only apply to $t$- and $u$-channels, while for $s$-channel resonances ' // & 'the maximum virtuality is set by $m^2$. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str & ("?ps_isr_only_onshell_emitted_partons"), .false., intrinsic=.true., & description=var_str ('This flag if set true sets all emitted ' // & 'partons off space-like showers on-shell, i.e. it would not allow ' // & 'associated time-like showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) end subroutine var_list_set_shower_defaults @ %def var_list_set_shower_defaults @ <>= procedure :: set_hadronization_defaults => var_list_set_hadronization_defaults <>= subroutine var_list_set_hadronization_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log & (var_str ("?allow_hadronization"), .true., intrinsic=.true., & description=var_str ('Master flag to switch on hadronization ' // & 'as an event transform. As a default, it is switched on. (cf. ' // & 'also \ttt{?ps\_ ....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, ' // & '\ttt{?hadronization\_active})')) call var_list%append_log & (var_str ("?hadronization_active"), .false., intrinsic=.true., & description=var_str ('Master flag to switch hadronization (through ' // & 'the attached \pythia\ package) on or off. As a default, it is ' // & 'off. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...})')) call var_list%append_string & (var_str ("$hadronization_method"), var_str ("PYTHIA6"), intrinsic = .true., & description=var_str ("Determines whether \whizard's own " // & "hadronization or the (internally included) \pythiasix\ should be used.")) call var_list%append_real & (var_str ("hadron_enhanced_fraction"), 0.01_default, intrinsic = .true., & description=var_str ('Fraction of Lund strings that break with enhanced ' // & 'width. [not yet active]')) call var_list%append_real & (var_str ("hadron_enhanced_width"), 2.0_default, intrinsic = .true., & description=var_str ('Enhancement factor for the width of breaking ' // & 'Lund strings. [not yet active]')) end subroutine var_list_set_hadronization_defaults @ %def var_list_set_hadronization_defaults @ <>= procedure :: set_tauola_defaults => var_list_set_tauola_defaults <>= subroutine var_list_set_tauola_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (& var_str ("?ps_tauola_photos"), .false., intrinsic=.true., & description=var_str ('Flag to switch on \ttt{PHOTOS} for photon ' // & 'showering inside the \ttt{TAUOLA} package. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_log (& var_str ("?ps_tauola_transverse"), .false., intrinsic=.true., & description=var_str ('Flag to switch transverse $\tau$ polarization ' // & 'on or off for Higgs decays into $\tau$ leptons. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_log (& var_str ("?ps_tauola_dec_rad_cor"), .true., intrinsic=.true., & description=var_str ('Flag to switch radiative corrections for ' // & '$\tau$ decays in \ttt{TAUOLA} on or off. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_int (& var_str ("ps_tauola_dec_mode1"), 0, intrinsic = .true., & description=var_str ('Integer code to request a specific $\tau$ ' // & 'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // & 'in correlated decays -- for the second $\tau$. For more information ' // & 'cf. the comments in the code or the \ttt{TAUOLA} manual. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_int (& var_str ("ps_tauola_dec_mode2"), 0, intrinsic = .true., & description=var_str ('Integer code to request a specific $\tau$ ' // & 'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // & 'in correlated decays -- for the second $\tau$. For more information ' // & 'cf. the comments in the code or the \ttt{TAUOLA} manual. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_real (& var_str ("ps_tauola_mh"), 125._default, intrinsic = .true., & description=var_str ('Real option to set the Higgs mass for Higgs ' // & 'decays into $\tau$ leptons in the interface to \ttt{TAUOLA}. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_real (& var_str ("ps_tauola_mix_angle"), 90._default, intrinsic = .true., & description=var_str ('Option to set the mixing angle between ' // & 'scalar and pseudoscalar Higgs bosons for Higgs decays into $\tau$ ' // & 'leptons in the interface to \ttt{TAUOLA}. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_log (& var_str ("?ps_tauola_pol_vector"), .false., intrinsic = .true., & description=var_str ('Flag to decide whether for transverse $\tau$ ' // & 'polarization, polarization information should be taken from ' // & '\ttt{TAUOLA} or not. The default is just based on random numbers. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) end subroutine var_list_set_tauola_defaults @ %def var_list_set_tauola_defaults @ <>= procedure :: set_mlm_matching_defaults => var_list_set_mlm_matching_defaults <>= subroutine var_list_set_mlm_matching_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?mlm_matching"), .false., & intrinsic=.true., & description=var_str ('Master flag to switch on MLM (LO) jet ' // & 'matching between hard matrix elements and the QCD parton ' // & 'shower. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Qcut_ME"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that in the MLM jet matching ' // & 'between hard matrix elements and QCD parton shower sets a possible ' // & 'virtuality cut on jets from the hard matrix element. (cf. also ' // & '\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // & '...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Qcut_PS"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that in the MLM jet matching ' // & 'between hard matrix elements and QCD parton shower sets a possible ' // & 'virtuality cut on jets from the parton shower. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_ptmin"), 0._default, intrinsic = .true., & description=var_str ('This real parameter sets a minimal $p_T$ ' // & 'that enters the $y_{cut}$ jet clustering measure in the MLM ' // & 'jet matching between hard matrix elements and QCD parton showers. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_etamax"), 0._default, intrinsic = .true., & description=var_str ('This real parameter sets a maximal pseudorapidity ' // & 'that enters the MLM jet matching between hard matrix elements ' // & 'and QCD parton showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Rmin"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that sets a minimal $R$ ' // & 'distance value that enters the $y_{cut}$ jet clustering measure ' // & 'in the MLM jet matching between hard matrix elements and QCD ' // & 'parton showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Emin"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that sets a minimal energy ' // & '$E_{min}$ value as an infrared cutoff in the MLM jet matching ' // & 'between hard matrix elements and QCD parton showers. (cf. also ' // & '\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // & '...}, \ttt{?hadronization\_active})')) call var_list%append_int (var_str & ("mlm_nmaxMEjets"), 0, intrinsic = .true., & description=var_str ('This integer sets the maximal number of ' // & 'jets that are available from hard matrix elements in the MLM ' // & 'jet matching between hard matrix elements and QCD parton shower. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_ETclusfactor"), 0.2_default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_ETclusminE"), 5._default, intrinsic = .true., & description=var_str ('This real parameter is a minimal energy ' // & 'that enters the calculation of the $y_{cut}$ measure for jet ' // & 'clustering after the parton shower in the MLM jet matching between ' // & 'hard matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_etaclusfactor"), 1._default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Rclusfactor"), 1._default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Eclusfactor"), 1._default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) end subroutine var_list_set_mlm_matching_defaults @ %def var_list_set_mlm_matching_defaults @ <>= procedure :: set_powheg_matching_defaults => & var_list_set_powheg_matching_defaults <>= subroutine var_list_set_powheg_matching_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?powheg_matching"), & .false., intrinsic = .true., & description=var_str ('Activates Powheg matching. Needs to be ' // & 'combined with the \ttt{?combined\_nlo\_integration}-method.')) call var_list%append_log (var_str ("?powheg_use_singular_jacobian"), & .false., intrinsic = .true., & description=var_str ('This allows to give a different ' // & 'normalization of the Jacobian, resulting in an alternative ' // & 'POWHEG damping in the singular regions.')) call var_list%append_int (var_str ("powheg_grid_size_xi"), & 5, intrinsic = .true., & description=var_str ('Number of $\xi$ points in the POWHEG grid.')) call var_list%append_int (var_str ("powheg_grid_size_y"), & 5, intrinsic = .true., & description=var_str ('Number of $y$ points in the POWHEG grid.')) call var_list%append_real (var_str ("powheg_pt_min"), & 1._default, intrinsic = .true., & description=var_str ('Lower $p_T$-cut-off for the POWHEG ' // & 'hardest emission.')) call var_list%append_real (var_str ("powheg_lambda"), & LAMBDA_QCD_REF, intrinsic = .true., & description=var_str ('Reference scale of the $\alpha_s$ evolution ' // & 'in the POWHEG matching algorithm.')) call var_list%append_log (var_str ("?powheg_test_sudakov"), & .false., intrinsic = .true., & description=var_str ('Performs an internal consistency check ' // & 'on the POWHEG event generation.')) call var_list%append_log (var_str ("?powheg_disable_sudakov"), & .false., intrinsic = .true., & description=var_str ('This flag allows to set the Sudakov form ' // & 'factor to one. This effectively results in a version of ' // & 'the matrix-element method (MEM) at NLO.')) end subroutine var_list_set_powheg_matching_defaults @ %def var_list_set_powheg_matching_defaults @ <>= procedure :: set_openmp_defaults => var_list_set_openmp_defaults <>= subroutine var_list_set_openmp_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?omega_openmp"), & openmp_is_active (), & intrinsic=.true., & description=var_str ('Flag to switch on or off OpenMP multi-threading ' // & "for \oMega\ matrix elements. (cf. also \ttt{\$method}, \ttt{\$omega\_flag})")) call var_list%append_log (var_str ("?openmp_is_active"), & openmp_is_active (), & locked=.true., intrinsic=.true., & description=var_str ('Flag to switch on or off OpenMP multi-threading ' // & 'for \whizard. (cf. also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, ' // & '\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})')) call var_list%append_int (var_str ("openmp_num_threads_default"), & openmp_get_default_max_threads (), & locked=.true., intrinsic=.true., & description=var_str ('Integer parameter that shows the number ' // & 'of default OpenMP threads for multi-threading. Note that this ' // & 'parameter can only be accessed, but not reset by the user. (cf. ' // & 'also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, \ttt{?omega\_openmp})')) call var_list%append_int (var_str ("openmp_num_threads"), & openmp_get_max_threads (), & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of OpenMP threads for multi-threading. (cf. also \ttt{?openmp\_logging}, ' // & '\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})')) call var_list%append_log (var_str ("?openmp_logging"), & .true., intrinsic=.true., & description=var_str ('This logical -- when set to \ttt{false} ' // & '-- suppresses writing out messages about OpenMP parallelization ' // & '(number of used threads etc.) on screen and into the logfile ' // & '(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // & 'Mainly for debugging purposes. (cf. also \ttt{?logging}, ' // & '\ttt{?mpi\_logging})')) end subroutine var_list_set_openmp_defaults @ %def var_list_set_openmp_defaults @ <>= procedure :: set_mpi_defaults => var_list_set_mpi_defaults <>= subroutine var_list_set_mpi_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?mpi_logging"), & .false., intrinsic=.true., & description=var_str('This logical -- when set to \ttt{false} ' // & '-- suppresses writing out messages about MPI parallelization ' // & '(number of used workers etc.) on screen and into the logfile ' // & '(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // & 'Mainly for debugging purposes. (cf. also \ttt{?logging}, ' // & '\ttt{?openmp\_logging})')) end subroutine var_list_set_mpi_defaults @ %def var_list_set_mpi_defaults @ <>= procedure :: set_nlo_defaults => var_list_set_nlo_defaults <>= subroutine var_list_set_nlo_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$born_me_method"), & var_str (""), intrinsic = .true., & description=var_str ("This string variable specifies the method " // & "for the matrix elements to be used in the evaluation of the " // & "Born part of the NLO computation. The default is the empty string, " // & "i.e. the \ttt{\$method} being the intrinsic \oMega\ matrix element " // & 'generator (\ttt{"omega"}), other options ' // & 'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, ' // & '\ttt{"template\_unity"}, \ttt{"threshold"}, \ttt{"gosam"}, ' // & '\ttt{"openloops"}. Note that this option is inoperative if ' // & 'no NLO calculation is specified in the process definition. ' // & 'If you want ot use different matrix element methods in a LO ' // & 'computation, use the usual \ttt{method} command. (cf. also ' // & '\ttt{\$correlation\_me\_method}, ' // & '\ttt{\$dglap\_me\_method}, \ttt{\$loop\_me\_method} and ' // & '\ttt{\$real\_tree\_me\_method}.)')) call var_list%append_string (var_str ("$loop_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation of the ' // & 'virtual part of the NLO computation. The default is the empty string, ' // & 'i.e. the same as \ttt{\$method}. Working options are: ' // & '\ttt{"threshold"}, \ttt{"openloops"}, \ttt{"recola"}, \ttt{"gosam"}. ' // & '(cf. also \ttt{\$real\_tree\_me\_method}, \ttt{\$correlation\_me\_method} ' // & 'and \ttt{\$born\_me\_method}.)')) call var_list%append_string (var_str ("$correlation_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies ' // & 'the method for the matrix elements to be used in the evaluation ' // & 'of the color (and helicity) correlated part of the NLO computation. ' // & "The default is the same as the \ttt{\$method}, i.e. the intrinsic " // & "\oMega\ matrix element generator " // & '(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // & '\ttt{"template"}, \ttt{"template\_unity"}, \ttt{"threshold"}, ' // & '\ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // & '\ttt{\$born\_me\_method}, \ttt{\$dglap\_me\_method}, ' // & '\ttt{\$loop\_me\_method} and \newline' // & '\ttt{\$real\_tree\_me\_method}.)')) call var_list%append_string (var_str ("$real_tree_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation of the ' // & 'real part of the NLO computation. The default is the same as ' // & 'the \ttt{\$method}, i.e. the intrinsic ' // & "\oMega\ matrix element generator " // & '(\ttt{"omega"}), other options ' // & 'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // & '\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // & '\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // & '\ttt{\$dglap\_me\_method} and \ttt{\$loop\_me\_method}.)')) call var_list%append_string (var_str ("$dglap_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation of the ' // & 'DGLAP remnants of the NLO computation. The default is the same as ' // & "\ttt{\$method}, i.e. the \oMega\ matrix element generator " // & '(\ttt{"omega"}), other options ' // & 'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // & '\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also \newline' // & '\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // & '\ttt{\$loop\_me\_method} and \ttt{\$real\_tree\_me\_method}.)')) call var_list%append_log (& var_str ("?test_soft_limit"), .false., intrinsic = .true., & description=var_str ('Sets the fixed values $\tilde{\xi} = 0.00001$ ' // & 'and $y = 0.5$ as radiation variables. This way, only soft, ' // & 'but non-collinear phase space points are generated, which allows ' // & 'for testing subtraction in this region.')) call var_list%append_log (& var_str ("?test_coll_limit"), .false., intrinsic = .true., & description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // & 'and $y = 0.9999999$ as radiation variables. This way, only collinear, ' // & 'but non-soft phase space points are generated, which allows ' // & 'for testing subtraction in this region. Can be combined with ' // & '\ttt{?test\_soft\_limit} to probe soft-collinear regions.')) call var_list%append_log (& var_str ("?test_anti_coll_limit"), .false., intrinsic = .true., & description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // & 'and $y = -0.9999999$ as radiation variables. This way, only anti-collinear, ' // & 'but non-soft phase space points are generated, which allows ' // & 'for testing subtraction in this region. Can be combined with ' // & '\ttt{?test\_soft\_limit} to probe soft-collinear regions.')) call var_list%append_string (var_str ("$select_alpha_regions"), & var_str (""), intrinsic = .true., & description=var_str ('Fixes the $\alpha_r$ in the real ' // & ' subtraction component. Allows for testing in one individual ' // & 'singular region.')) call var_list%append_string (var_str ("$virtual_selection"), & var_str ("Full"), intrinsic = .true., & description=var_str ('String variable to select either the full ' // & 'or only parts of the virtual components of an NLO calculation. ' // & 'Possible modes are \ttt{"Full"}, \ttt{"OLP"} and ' // & '\ttt{"Subtraction."}. Mainly for debugging purposes.')) call var_list%append_log (var_str ("?virtual_collinear_resonance_aware"), & .true., intrinsic = .true., & description=var_str ('This flag allows to switch between two ' // & 'different implementations of the collinear subtraction in the ' // & 'resonance-aware FKS setup.')) call var_list%append_real (& var_str ("blha_top_yukawa"), -1._default, intrinsic = .true., & description=var_str ('If this value is set, the given value will ' // & 'be used as the top Yukawa coupling instead of the top mass. ' // & 'Note that having different values for $y_t$ and $m_t$ must be ' // & 'supported by your OLP-library and yield errors if this is not the case.')) call var_list%append_string (var_str ("$blha_ew_scheme"), & var_str ("alpha_internal"), intrinsic = .true., & description=var_str ('String variable that transfers the electroweak ' // & 'renormalization scheme via BLHA to the one-loop provider. Possible ' // & 'values are \ttt{GF} or \ttt{Gmu} for the $G_\mu$ scheme, ' // & '\ttt{alpha\_internal} (default, $G_\mu$ scheme, but value of ' // & '$\alpha_S$ calculated internally by \whizard), \ttt{alpha\_mz} ' // & 'and \ttt{alpha\_0} (or \ttt{alpha\_thompson}) for different schemes ' // & 'with $\alpha$ as input.')) call var_list%append_int (var_str ("openloops_verbosity"), 1, & intrinsic = .true., & description=var_str ('Decides how much \openloops\ output is printed. ' // & 'Can have values 0, 1 and 2, where 2 is the highest verbosity level.')) call var_list%append_log (var_str ("?openloops_use_cms"), & .true., intrinsic = .true., & description=var_str ('Activates the complex mass scheme in ' // & '\openloops. (cf. also ' // & '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // & '\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // & '\ttt{openloops\_stability\_log}, \newline' // & '\ttt{\$openloops\_extra\_cmd})')) call var_list%append_int (var_str ("openloops_phs_tolerance"), 7, & intrinsic = .true., & description=var_str ('This integer parameter gives via ' // & '\ttt{openloops\_phs\_tolerance = } the relative numerical ' // & 'tolerance $10^{-n}$ for the momentum conservation of the ' // & 'external particles within \openloops. (cf. also ' // & '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // & '\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // & '\newline\ttt{openloops\_stability\_log}, ' // & '\ttt{\$openloops\_extra\_cmd})')) call var_list%append_int (var_str ("openloops_stability_log"), 0, & intrinsic = .true., & description=var_str ('Creates the directory \ttt{stability\_log} ' // & 'containing information about the performance of the \openloops ' // & 'matrix elements. Possible values are 0 (No output), 1 (On ' // & '\ttt{finish()}-call), 2 (Adaptive) and 3 (Always).')) call var_list%append_log (var_str ("?openloops_switch_off_muon_yukawa"), & .false., intrinsic = .true., & description=var_str ('Sets the Yukawa coupling of muons for ' // & '\openloops\ to zero. (cf. also ' // & '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // & '\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // & '\ttt{\$openloops\_extra\_cmd})')) call var_list%append_string (var_str ("$openloops_extra_cmd"), & var_str (""), intrinsic = .true., & description=var_str ('String variable to transfer customized ' // & 'special commands to \openloops. The three supported examples ' // & '\ttt{\$openloops\_extra\_command = "extra approx top/stop/not"} ' // & 'are for selection of subdiagrams in top production. (cf. also ' // & '\ttt{\$method}, \ttt{openloos\_verbosity}, ' // & '\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // & '\ttt{?openloops\_switch\_off\_muon\_yukawa})')) call var_list%append_real (var_str ("ellis_sexton_scale"), & -1._default, intrinsic = .true., & description = var_str ('Real positive paramter for the Ellis-Sexton scale' // & '$\mathcal{Q}$ used both in the finite one-loop contribution provided by' // & 'the OLP and in the virtual counter terms. The NLO cross section is' // & 'independent of $\mathcal{Q}$. Therefore, this allows for debugging of' // & 'the implemention of the virtual counter terms. As the default' // & '$\mathcal{Q} = \mu_{\rm{R}}$ is chosen. So far, setting this parameter' // & 'only works for OpenLoops2, otherwise the default behaviour is invoked.')) call var_list%append_log (var_str ("?disable_subtraction"), & .false., intrinsic = .true., & description=var_str ('Disables the subtraction of soft and collinear ' // & 'divergences from the real matrix element.')) call var_list%append_real (var_str ("fks_dij_exp1"), & 1._default, intrinsic = .true., & description=var_str ('Fine-tuning parameters of the FKS ' // & 'final state partition functions. The exact meaning depends ' // & 'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp2}, ' // & '\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})')) call var_list%append_real (var_str ("fks_dij_exp2"), & 1._default, intrinsic = .true., & description=var_str ('Fine-tuning parameters of the FKS ' // & 'initial state partition functions. The exact meaning depends ' // & 'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp1}, ' // & '\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})')) call var_list%append_real (var_str ("fks_xi_min"), & 0._default, intrinsic = .true., & description=var_str ('Real parameter for the FKS ' // & 'phase space that sets the numerical lower value of the $\xi$ ' // & 'variable. Valid for the value range $[\texttt{tiny\_07},1]$, where ' // & 'value inputs out of bounds will take the value of the closest bound. ' // & 'Here, $\texttt{tiny\_07} = \texttt{1E0\_default * epsilon (0.\_default)}$, where ' // & '\ttt{epsilon} is an intrinsic Fortran function. (cf. also \ttt{fks\_dij\_exp1}, ' // & '\ttt{fks\_dij\_exp2}, \ttt{\$fks\_mapping\_type}, \ttt{fks\_y\_max})')) call var_list%append_real (var_str ("fks_y_max"), & 1._default, intrinsic = .true., & description=var_str ('Real parameter for the FKS ' // & 'phase space that sets the numerical upper value of the $\left|y\right|$ ' // & 'variable. Valid for ranges $[0,1]$, where value inputs out of bounds will take ' // & 'the value of the closest bound. Only supported for massless FSR. ' // & '(cf. also \ttt{fks\_dij\_exp1}, \ttt{\$fks\_mapping\_type}, \ttt{fks\_dij\_exp2})')) call var_list%append_log (var_str ("?vis_fks_regions"), & .false., intrinsic = .true., & description=var_str ('Logical variable that, if set to ' // & '\ttt{true}, generates \LaTeX\ code and executes it into a PDF ' // & ' to produce a table of all singular FKS regions and their ' // & ' flavor structures. The default is \ttt{false}.')) call var_list%append_real (var_str ("fks_xi_cut"), & 1.0_default, intrinsic = .true., & description = var_str ('(Experimental) Real parameter for the FKS ' // & 'phase space that applies a cut to $\xi$ variable with $0 < \xi_{\text{cut}}' // & '\leq \xi_{\text{max}}$. The dependence on the parameter vanishes between ' // & 'real subtraction and integrated subtraction term. Could thus be used for debugging. ' // & 'This is not implemented properly, use at your own risk!')) call var_list%append_real (var_str ("fks_delta_o"), & 2._default, intrinsic = .true., & description = var_str ('Real parameter for the FKS ' // & 'phase space that applies a cut to the $y$ variable with $0 < \delta_o \leq 2$ ' // & 'for final state singularities only. ' // & 'The dependence on the parameter vanishes between real subtraction and integrated ' // & 'subtraction term. For debugging purposes.')) call var_list%append_real (var_str ("fks_delta_i"), & 2._default, intrinsic = .true., & description = var_str ('Real parameter for the FKS ' // & 'phase space that applies a cut to the $y$ variable with ' // & '$0 < \delta_{\mathrm{I}} \leq 2$ '// & 'for initial state singularities only. ' // & 'The dependence on the parameter vanishes between real subtraction and integrated ' // & 'subtraction term. For debugging purposes.')) call var_list%append_string (var_str ("$fks_mapping_type"), & var_str ("default"), intrinsic = .true., & description=var_str ('Sets the FKS mapping type. Possible values ' // & 'are \ttt{"default"} and \ttt{"resonances"}. The latter option ' // & 'activates the resonance-aware subtraction mode and induces the ' // & 'generation of a soft mismatch component. (cf. also ' // & '\ttt{fks\_dij\_exp1}, \ttt{fks\_dij\_exp2}, \ttt{fks\_xi\_min}, ' // & '\ttt{fks\_y\_max})')) call var_list%append_string (var_str ("$resonances_exclude_particles"), & var_str ("default"), intrinsic = .true., & description=var_str ('Accepts a string of particle names. These ' // & 'particles will be ignored when the resonance histories are generated. ' // & 'If \ttt{\$fks\_mapping\_type} is not \ttt{"resonances"}, this ' // & 'option does nothing.')) call var_list%append_int (var_str ("alpha_power"), & 2, intrinsic = .true., & description=var_str ('Fixes the electroweak coupling ' // & 'powers used by BLHA matrix element generators. Setting these ' // & 'values is necessary for the correct generation of OLP-files. ' // & 'Having inconsistent values yields to error messages by the corresponding ' // & 'OLP-providers.')) call var_list%append_int (var_str ("alphas_power"), & 0, intrinsic = .true., & description=var_str ('Fixes the strong coupling ' // & 'powers used by BLHA matrix element generators. Setting these ' // & 'values is necessary for the correct generation of OLP-files. ' // & 'Having inconsistent values yields to error messages by the corresponding ' // & 'OLP-providers.')) call var_list%append_log (var_str ("?combined_nlo_integration"), & .false., intrinsic = .true., & description=var_str ('When this option is set to \ttt{true}, ' // & 'the NLO integration will not be performed in the separate components, ' // & 'but instead the sum of all components will be integrated directly. ' // & 'When fixed-order NLO events are requested, this integration ' // & 'mode is possible, but not necessary. However, it is necessary ' // & 'for POWHEG events.')) call var_list%append_log (var_str ("?fixed_order_nlo_events"), & .false., intrinsic = .true., & description=var_str ('Induces the generation of fixed-order ' // & 'NLO events.')) call var_list%append_log (var_str ("?check_event_weights_against_xsection"), & .false., intrinsic = .true., & description=var_str ('Activates an internal recording of event ' // & 'weights when unweighted events are generated. At the end of ' // & 'the simulation, the mean value of the weights and its standard ' // & 'deviation are displayed. This allows to cross-check event generation ' // & 'and integration, because the value displayed must be equal to ' // & 'the integration result.')) call var_list%append_log (var_str ("?keep_failed_events"), & .false., intrinsic = .true., & description=var_str ('In the context of weighted event generation, ' // & 'if set to \ttt{true}, events with failed kinematics will be ' // & 'written to the event output with an associated weight of zero. ' // & 'This way, the total cross section can be reconstructed from the event output.')) call var_list%append_int (var_str ("gks_multiplicity"), & 0, intrinsic = .true., & description=var_str ('Jet multiplicity for the GKS merging scheme.')) call var_list%append_string (var_str ("$gosam_filter_lo"), & var_str (""), intrinsic = .true., & description=var_str ('The filter string given to \gosam\ in order to ' // & 'filter out tree-level diagrams. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // & '\ttt{\$gosam\_symmetries})')) call var_list%append_string (var_str ("$gosam_filter_nlo"), & var_str (""), intrinsic = .true., & description=var_str ('The same as \ttt{\$gosam\_filter\_lo}, but for ' // & 'loop matrix elements. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // & '\ttt{\$gosam\_symmetries})')) call var_list%append_string (var_str ("$gosam_symmetries"), & var_str ("family,generation"), intrinsic = .true., & description=var_str ('String variable that is transferred to \gosam\ ' // & 'configuration file to determine whether certain helicity configurations ' // & 'are considered to be equal. Possible values are \ttt{flavour}, ' // & '\ttt{family} etc. For more info see the \gosam\ manual.')) call var_list%append_int (var_str ("form_threads"), & 2, intrinsic = .true., & description=var_str ('The number of threads used by \gosam\ when ' // & 'matrix elements are evaluated using \ttt{FORM}')) call var_list%append_int (var_str ("form_workspace"), & 1000, intrinsic = .true., & description=var_str ('The size of the workspace \gosam\ requires ' // & 'from \ttt{FORM}. Inside \ttt{FORM}, it corresponds to the heap ' // & 'size used by the algebra processor.')) call var_list%append_string (var_str ("$gosam_fc"), & var_str (""), intrinsic = .true., & description=var_str ('The Fortran compiler used by \gosam.')) call var_list%append_real (& var_str ("mult_call_real"), 1._default, & intrinsic = .true., & description=var_str ('(Real-valued) multiplier for the number ' // & 'of calls used in the integration of the real subtraction ' // & 'NLO component. This way, a higher accuracy can be achieved for ' // & 'the real component, while simultaneously avoiding redundant ' // & 'integration calls for the other components. (cf. also ' // & '\ttt{mult\_call\_dglap}, \ttt{mult\_call\_virt})')) call var_list%append_real (& var_str ("mult_call_virt"), 1._default, & intrinsic = .true., & description=var_str ('(Real-valued) multiplier for the number ' // & 'of calls used in the integration of the virtual NLO ' // & 'component. This way, a higher accuracy can be achieved for ' // & 'this component, while simultaneously avoiding redundant ' // & 'integration calls for the other components. (cf. also ' // & '\ttt{mult\_call\_dglap}, \ttt{mult\_call\_real})')) call var_list%append_real (& var_str ("mult_call_dglap"), 1._default, & intrinsic = .true., & description=var_str ('(Real-valued) multiplier for the number ' // & 'of calls used in the integration of the DGLAP remnant NLO ' // & 'component. This way, a higher accuracy can be achieved for ' // & 'this component, while simultaneously avoiding redundant ' // & 'integration calls for the other components. (cf. also ' // & '\ttt{mult\_call\_real}, \ttt{mult\_call\_virt})')) call var_list%append_string (var_str ("$dalitz_plot"), & var_str (''), intrinsic = .true., & description=var_str ('This string variable has two purposes: ' // & 'when different from the empty string, it switches on generation ' // & 'of the Dalitz plot file (ASCII tables) for the real emitters. ' // & 'The string variable itself provides the file name.')) call var_list%append_string (var_str ("$nlo_correction_type"), & var_str ("QCD"), intrinsic = .true., & description=var_str ('String variable which sets the NLO correction ' // & 'type via \ttt{nlo\_correction\_type = "{\em }"} to either ' // & '\ttt{"QCD"}, \ttt{"EW"}, or to all with \ttt{\em{}} ' // & 'set to \ttt{"Full"}. Must be set before the \texttt{process} statement.')) call var_list%append_string (var_str ("$exclude_gauge_splittings"), & var_str ("c:b:t:e2:e3"), intrinsic = .true., & description=var_str ('String variable that allows via ' // & '\ttt{\$exclude\_gauge\_splittings = "{\em ::\dots}"} ' // & 'to exclude fermion flavors from gluon/photon splitting into ' // & 'fermion pairs beyond LO. For example \ttt{\$exclude\_gauge\_splittings ' // & '= "c:s:b:t"} would lead to \ttt{gl => u U} and \ttt{gl => d ' // & 'D} as possible splittings in QCD. It is important to keep in ' // & 'mind that only the particles listed in the string are excluded! ' // & 'In QED this string would additionally allow for all splittings into ' // & 'lepton pairs \ttt{A => l L}. Therefore, once set the variable ' // & 'acts as a replacement of the default value, not as an addition! ' // & 'Note: \ttt{"\em "} can be both particle or antiparticle. It ' // & 'will always exclude the corresponding fermion pair. An empty ' // & 'string allows for all fermion flavors to take part in the splitting! ' // & 'Also, particles included in an \ttt{alias} are not excluded by ' // & '\ttt{\$exclude\_gauge\_splittings}!')) call var_list%append_log (var_str ("?nlo_use_born_scale"), & .false., intrinsic = .true., & description=var_str ('Flag that decides whether a scale expression ' // & 'defined for the Born component of an NLO process shall be applied ' // & 'to all other components as well or not. ' // & '(cf. also \ttt{?nlo\_cut\_all\_real\_sqmes})')) call var_list%append_log (var_str ("?nlo_cut_all_real_sqmes"), & .false., intrinsic = .true., & description=var_str ('Flag that decides whether in the case that ' // & 'the real component does not pass a cut, its subtraction term ' // & 'shall be discarded for that phase space point as well or not. ' // & '(cf. also \ttt{?nlo\_use\_born\_scale})')) call var_list%append_string (var_str ("$real_partition_mode"), var_str ("default"), & intrinsic=.true., & description=var_str ('String variable to choose which parts of the real cross ' // & 'section are to be integrated. With the default value (\ttt{"default"}) ' // & 'or \ttt{"off"} the real cross section is integrated as usual without partition. ' // & 'If set to \ttt{"on"} or \ttt{"all"}, the real cross section is split into singular ' // & 'and finite part using a partition function $F$, such that $\mathcal{R} ' // & '= [1-F(p_T^2)]\mathcal{R} + F(p_T^2)\mathcal{R} = \mathcal{R}_{\text{fin}} ' // & '+ \mathcal{R}_{\text{sing}}$. The emission generation is then performed ' // & 'using $\mathcal{R}_{\text{sing}}$, whereas $\mathcal{R}_{\text{fin}}$ ' // & 'is treated separately. If set to \ttt{"singular"} (\ttt{"finite"}), ' // & 'only the singular (finite) real component is integrated.' // & '(cf. also \ttt{real\_partition\_scale})')) call var_list%append_real (var_str ("real_partition_scale"), & 10._default, intrinsic = .true., & description=var_str ('This real variable sets the invariant mass ' // & 'of the FKS pair used as a separator between the singular and the ' // & 'finite part of the real subtraction terms in an NLO calculation, ' // & 'e.g. in $e^+e^- \to t\bar tj$. (cf. also \ttt{\$real\_partition\_mode})')) call var_list%append_log (var_str ("?nlo_reuse_amplitudes_fks"), & .false., intrinsic = .true., & description=var_str ('Only compute real and virtual amplitudes for ' // & 'subprocesses that give a different amplitude and reuse the result ' // & 'for equivalent subprocesses. ' // & 'Might give a speed-up for some processes. Might ' // & 'break others, especially in cases where resonance histories are needed. ' // & 'Experimental feature, use at your own risk!')) end subroutine var_list_set_nlo_defaults @ %def var_list_set_nlo_defaults @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Observables} In this module we define concrete variables and operators (observables) that we want to support in expressions. <<[[observables.f90]]>>= <> module observables <> <> use io_units use diagnostics use lorentz use subevents use variables <> <> contains <> end module observables @ %def observables @ \subsection{Process-specific variables} We allow the user to set a numeric process ID for each declared process. <>= public :: var_list_init_num_id <>= subroutine var_list_init_num_id (var_list, proc_id, num_id) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id integer, intent(in), optional :: num_id call var_list_set_procvar_int (var_list, proc_id, & var_str ("num_id"), num_id) end subroutine var_list_init_num_id @ %def var_list_init_num_id @ Integration results are stored in special variables. They are initialized by this subroutine. The values may or may not already known. Note: the values which are accessible are those that are unique for a process with multiple MCI records. The rest has been discarded. <>= public :: var_list_init_process_results <>= subroutine var_list_init_process_results (var_list, proc_id, & n_calls, integral, error, accuracy, chi2, efficiency) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id integer, intent(in), optional :: n_calls real(default), intent(in), optional :: integral, error, accuracy real(default), intent(in), optional :: chi2, efficiency call var_list_set_procvar_real (var_list, proc_id, & var_str ("integral"), integral) call var_list_set_procvar_real (var_list, proc_id, & var_str ("error"), error) end subroutine var_list_init_process_results @ %def var_list_init_process_results @ \subsection{Observables as Pseudo-Variables} Unary and binary observables are different. Most unary observables can be equally well evaluated for particle pairs. Binary observables cannot be evaluated for single particles. <>= public :: var_list_set_observables_unary public :: var_list_set_observables_binary public :: var_list_set_observables_sev <>= subroutine var_list_set_observables_unary (var_list, prt1) type(var_list_t), intent(inout) :: var_list type(prt_t), intent(in), target :: prt1 call var_list_append_obs1_iptr & (var_list, var_str ("PDG"), obs_pdg1, prt1) call var_list_append_obs1_iptr & (var_list, var_str ("Hel"), obs_helicity1, prt1) call var_list_append_obs1_iptr & (var_list, var_str ("Ncol"), obs_n_col1, prt1) call var_list_append_obs1_iptr & (var_list, var_str ("Nacl"), obs_n_acl1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("M"), obs_signed_mass1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("M2"), obs_mass_squared1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("E"), obs_energy1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("Px"), obs_px1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("Py"), obs_py1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("Pz"), obs_pz1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("P"), obs_p1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("Pl"), obs_pl1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("Pt"), obs_pt1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("Theta"), obs_theta1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("Phi"), obs_phi1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("Rap"), obs_rap1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("Eta"), obs_eta1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("Theta_star"), obs_theta_star1, prt1) call var_list_append_obs1_rptr & (var_list, var_str ("Dist"), obs_dist1, prt1) call var_list_append_uobs_real & (var_list, var_str ("_User_obs_real"), prt1) call var_list_append_uobs_int & (var_list, var_str ("_User_obs_int"), prt1) end subroutine var_list_set_observables_unary subroutine var_list_set_observables_binary (var_list, prt1, prt2) type(var_list_t), intent(inout) :: var_list type(prt_t), intent(in), target :: prt1 type(prt_t), intent(in), optional, target :: prt2 call var_list_append_obs2_iptr & (var_list, var_str ("PDG"), obs_pdg2, prt1, prt2) call var_list_append_obs2_iptr & (var_list, var_str ("Hel"), obs_helicity2, prt1, prt2) call var_list_append_obs2_iptr & (var_list, var_str ("Ncol"), obs_n_col2, prt1, prt2) call var_list_append_obs2_iptr & (var_list, var_str ("Nacl"), obs_n_acl2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("M"), obs_signed_mass2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("M2"), obs_mass_squared2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("E"), obs_energy2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("Px"), obs_px2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("Py"), obs_py2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("Pz"), obs_pz2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("P"), obs_p2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("Pl"), obs_pl2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("Pt"), obs_pt2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("Theta"), obs_theta2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("Phi"), obs_phi2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("Rap"), obs_rap2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("Eta"), obs_eta2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("Theta_star"), obs_theta_star2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("Dist"), obs_dist2, prt1, prt2) call var_list_append_obs2_rptr & (var_list, var_str ("kT"), obs_ktmeasure, prt1, prt2) call var_list_append_uobs_real & (var_list, var_str ("_User_obs_real"), prt1, prt2) call var_list_append_uobs_int & (var_list, var_str ("_User_obs_int"), prt1, prt2) end subroutine var_list_set_observables_binary subroutine var_list_set_observables_sev (var_list, pval) type(var_list_t), intent(inout) :: var_list type(subevt_t), intent(in), target:: pval call var_list_append_obsev_rptr & (var_list, var_str ("Ht"), obs_ht, pval) end subroutine var_list_set_observables_sev @ %def var_list_set_observables_unary var_list_set_observables_binary @ %def var_list_set_observables_nary \subsection{Checks} <>= public :: var_list_check_observable <>= subroutine var_list_check_observable (var_list, name, type) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(inout) :: type if (string_is_observable_id (name)) then call msg_fatal ("Variable name '" // char (name) & // "' is reserved for an observable") type = V_NONE return end if end subroutine var_list_check_observable @ %def var_list_check_observable @ Check if a variable name is defined as an observable: <>= function string_is_observable_id (string) result (flag) logical :: flag type(string_t), intent(in) :: string select case (char (string)) case ("PDG", "Hel", "Ncol", "Nacl", & "M", "M2", "E", "Px", "Py", "Pz", "P", "Pl", "Pt", & "Theta", "Phi", "Rap", "Eta", "Theta_star", "Dist", "kT", & "Ht") flag = .true. case default flag = .false. end select end function string_is_observable_id @ %def string_is_observable_id @ Check for result and process variables. <>= public :: var_list_check_result_var <>= subroutine var_list_check_result_var (var_list, name, type) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(inout) :: type if (string_is_integer_result_var (name)) type = V_INT if (.not. var_list%contains (name)) then if (string_is_result_var (name)) then call msg_fatal ("Result variable '" // char (name) // "' " & // "set without prior integration") type = V_NONE return else if (string_is_num_id (name)) then call msg_fatal ("Numeric process ID '" // char (name) // "' " & // "set without process declaration") type = V_NONE return end if end if end subroutine var_list_check_result_var @ %def var_list_check_result_var @ Check if a variable name is a result variable of integer type: <>= function string_is_integer_result_var (string) result (flag) logical :: flag type(string_t), intent(in) :: string type(string_t) :: buffer, name, separator buffer = string call split (buffer, name, "(", separator=separator) ! ")" if (separator == "(") then select case (char (name)) case ("num_id", "n_calls") flag = .true. case default flag = .false. end select else flag = .false. end if end function string_is_integer_result_var @ %def string_is_integer_result_var @ Check if a variable name is an integration-result variable: <>= function string_is_result_var (string) result (flag) logical :: flag type(string_t), intent(in) :: string type(string_t) :: buffer, name, separator buffer = string call split (buffer, name, "(", separator=separator) ! ")" if (separator == "(") then select case (char (name)) case ("integral", "error") flag = .true. case default flag = .false. end select else flag = .false. end if end function string_is_result_var @ %def string_is_result_var @ Check if a variable name is a numeric process ID: <>= function string_is_num_id (string) result (flag) logical :: flag type(string_t), intent(in) :: string type(string_t) :: buffer, name, separator buffer = string call split (buffer, name, "(", separator=separator) ! ")" if (separator == "(") then select case (char (name)) case ("num_id") flag = .true. case default flag = .false. end select else flag = .false. end if end function string_is_num_id @ %def string_is_num_id @ \subsection{Observables} These are analogous to the unary and binary numeric functions listed above. An observable takes the [[pval]] component(s) of its one or two argument nodes and produces an integer or real value. \subsubsection{Integer-valued unary observables} The PDG code <>= integer function obs_pdg1 (prt1) result (pdg) type(prt_t), intent(in) :: prt1 pdg = prt_get_pdg (prt1) end function obs_pdg1 @ %def obs_pdg @ The helicity. The return value is meaningful only if the particle is polarized, otherwise an invalid value is returned (-9). <>= integer function obs_helicity1 (prt1) result (h) type(prt_t), intent(in) :: prt1 if (prt_is_polarized (prt1)) then h = prt_get_helicity (prt1) else h = -9 end if end function obs_helicity1 @ %def obs_helicity1 @ The number of open color (anticolor) lines. The return value is meaningful only if the particle is colorized (i.e., the subevent has been given color information), otherwise the function returns zero. <>= integer function obs_n_col1 (prt1) result (n) type(prt_t), intent(in) :: prt1 if (prt_is_colorized (prt1)) then n = prt_get_n_col (prt1) else n = 0 end if end function obs_n_col1 integer function obs_n_acl1 (prt1) result (n) type(prt_t), intent(in) :: prt1 if (prt_is_colorized (prt1)) then n = prt_get_n_acl (prt1) else n = 0 end if end function obs_n_acl1 @ %def obs_n_col1 @ %def obs_n_acl1 @ \subsubsection{Real-valued unary observables} The invariant mass squared, obtained from the separately stored value. <>= real(default) function obs_mass_squared1 (prt1) result (p2) type(prt_t), intent(in) :: prt1 p2 = prt_get_msq (prt1) end function obs_mass_squared1 @ %def obs_mass_squared1 @ The signed invariant mass, which is the signed square root of the previous observable. <>= real(default) function obs_signed_mass1 (prt1) result (m) type(prt_t), intent(in) :: prt1 real(default) :: msq msq = prt_get_msq (prt1) m = sign (sqrt (abs (msq)), msq) end function obs_signed_mass1 @ %def obs_signed_mass1 @ The particle energy <>= real(default) function obs_energy1 (prt1) result (e) type(prt_t), intent(in) :: prt1 e = energy (prt_get_momentum (prt1)) end function obs_energy1 @ %def obs_energy1 @ Particle momentum (components) <>= real(default) function obs_px1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = vector4_get_component (prt_get_momentum (prt1), 1) end function obs_px1 real(default) function obs_py1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = vector4_get_component (prt_get_momentum (prt1), 2) end function obs_py1 real(default) function obs_pz1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = vector4_get_component (prt_get_momentum (prt1), 3) end function obs_pz1 real(default) function obs_p1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = space_part_norm (prt_get_momentum (prt1)) end function obs_p1 real(default) function obs_pl1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = longitudinal_part (prt_get_momentum (prt1)) end function obs_pl1 real(default) function obs_pt1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = transverse_part (prt_get_momentum (prt1)) end function obs_pt1 @ %def obs_px1 obs_py1 obs_pz1 @ %def obs_p1 obs_pl1 obs_pt1 @ Polar and azimuthal angle (lab frame). <>= real(default) function obs_theta1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = polar_angle (prt_get_momentum (prt1)) end function obs_theta1 real(default) function obs_phi1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = azimuthal_angle (prt_get_momentum (prt1)) end function obs_phi1 @ %def obs_theta1 obs_phi1 @ Rapidity and pseudorapidity <>= real(default) function obs_rap1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = rapidity (prt_get_momentum (prt1)) end function obs_rap1 real(default) function obs_eta1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = pseudorapidity (prt_get_momentum (prt1)) end function obs_eta1 @ %def obs_rap1 obs_eta1 @ Meaningless: Polar angle in the rest frame of the two arguments combined. <>= real(default) function obs_theta_star1 (prt1) result (dist) type(prt_t), intent(in) :: prt1 call msg_fatal (" 'Theta_star' is undefined as unary observable") dist = 0 end function obs_theta_star1 @ %def obs_theta_star1 @ [Obsolete] Meaningless: Polar angle in the rest frame of the 2nd argument. <>= real(default) function obs_theta_rf1 (prt1) result (dist) type(prt_t), intent(in) :: prt1 call msg_fatal (" 'Theta_RF' is undefined as unary observable") dist = 0 end function obs_theta_rf1 @ %def obs_theta_rf1 @ Meaningless: Distance on the $\eta$-$\phi$ cylinder. <>= real(default) function obs_dist1 (prt1) result (dist) type(prt_t), intent(in) :: prt1 call msg_fatal (" 'Dist' is undefined as unary observable") dist = 0 end function obs_dist1 @ %def obs_dist1 @ \subsubsection{Integer-valued binary observables} These observables are meaningless as binary functions. <>= integer function obs_pdg2 (prt1, prt2) result (pdg) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" PDG_Code is undefined as binary observable") pdg = 0 end function obs_pdg2 integer function obs_helicity2 (prt1, prt2) result (h) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" Helicity is undefined as binary observable") h = 0 end function obs_helicity2 integer function obs_n_col2 (prt1, prt2) result (n) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" Ncol is undefined as binary observable") n = 0 end function obs_n_col2 integer function obs_n_acl2 (prt1, prt2) result (n) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" Nacl is undefined as binary observable") n = 0 end function obs_n_acl2 @ %def obs_pdg2 @ %def obs_helicity2 @ %def obs_n_col2 @ %def obs_n_acl2 @ \subsubsection{Real-valued binary observables} The invariant mass squared, obtained from the separately stored value. <>= real(default) function obs_mass_squared2 (prt1, prt2) result (p2) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p2 = prt_get_msq (prt) end function obs_mass_squared2 @ %def obs_mass_squared2 @ The signed invariant mass, which is the signed square root of the previous observable. <>= real(default) function obs_signed_mass2 (prt1, prt2) result (m) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt real(default) :: msq call prt_init_combine (prt, prt1, prt2) msq = prt_get_msq (prt) m = sign (sqrt (abs (msq)), msq) end function obs_signed_mass2 @ %def obs_signed_mass2 @ The particle energy <>= real(default) function obs_energy2 (prt1, prt2) result (e) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) e = energy (prt_get_momentum (prt)) end function obs_energy2 @ %def obs_energy2 @ Particle momentum (components) <>= real(default) function obs_px2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = vector4_get_component (prt_get_momentum (prt), 1) end function obs_px2 real(default) function obs_py2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = vector4_get_component (prt_get_momentum (prt), 2) end function obs_py2 real(default) function obs_pz2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = vector4_get_component (prt_get_momentum (prt), 3) end function obs_pz2 real(default) function obs_p2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = space_part_norm (prt_get_momentum (prt)) end function obs_p2 real(default) function obs_pl2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = longitudinal_part (prt_get_momentum (prt)) end function obs_pl2 real(default) function obs_pt2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = transverse_part (prt_get_momentum (prt)) end function obs_pt2 @ %def obs_px2 obs_py2 obs_pz2 @ %def obs_p2 obs_pl2 obs_pt2 @ Enclosed angle and azimuthal distance (lab frame). <>= real(default) function obs_theta2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 p = enclosed_angle (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_theta2 real(default) function obs_phi2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = azimuthal_distance (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_phi2 @ %def obs_theta2 obs_phi2 @ Rapidity and pseudorapidity distance <>= real(default) function obs_rap2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 p = rapidity_distance & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_rap2 real(default) function obs_eta2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = pseudorapidity_distance & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_eta2 @ %def obs_rap2 obs_eta2 @ [This doesn't work! The principle of no common particle for momentum combination prohibits us from combining a decay particle with the momentum of its parent.] Polar angle in the rest frame of the 2nd argument. <>= real(default) function obs_theta_rf2 (prt1, prt2) result (theta) type(prt_t), intent(in) :: prt1, prt2 theta = enclosed_angle_rest_frame & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_theta_rf2 @ %def obs_theta_rf2 @ Polar angle of the first particle in the rest frame of the two particles combined. <>= real(default) function obs_theta_star2 (prt1, prt2) result (theta) type(prt_t), intent(in) :: prt1, prt2 theta = enclosed_angle_rest_frame & (prt_get_momentum (prt1), & prt_get_momentum (prt1) + prt_get_momentum (prt2)) end function obs_theta_star2 @ %def obs_theta_star2 @ Distance on the $\eta$-$\phi$ cylinder. <>= real(default) function obs_dist2 (prt1, prt2) result (dist) type(prt_t), intent(in) :: prt1, prt2 dist = eta_phi_distance & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_dist2 @ %def obs_dist2 @ Durham kT measure. <>= real(default) function obs_ktmeasure (prt1, prt2) result (kt) type(prt_t), intent(in) :: prt1, prt2 real (default) :: q2, e1, e2 ! Normalized scale to one for now! (#67) q2 = 1 e1 = energy (prt_get_momentum (prt1)) e2 = energy (prt_get_momentum (prt2)) kt = (2/q2) * min(e1**2,e2**2) * & (1 - enclosed_angle_ct(prt_get_momentum (prt1), & prt_get_momentum (prt2))) end function obs_ktmeasure @ %def obs_ktmeasure @ Subeventary observables, e.g. the transverse mass $H_T$. <>= real(default) function obs_ht (sev) result (ht) type(subevt_t), intent(in) :: sev integer :: i, n type(prt_t) :: prt n = subevt_get_length (sev) ht = 0 do i = 1, n prt = subevt_get_prt (sev, i) ht = ht + & sqrt (obs_pt1(prt)**2 + obs_mass_squared1(prt)) end do end function obs_ht @ %def obs_ht