Index: trunk/src/utilities/utilities.nw =================================================================== --- trunk/src/utilities/utilities.nw (revision 8769) +++ trunk/src/utilities/utilities.nw (revision 8770) @@ -1,3653 +1,3652 @@ % -*- 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 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 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 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 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 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 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Binary Tree} <<[[binary_tree.f90]]>>= <> module binary_tree implicit none private <> <> interface <> end interface contains <> end module binary_tree @ %def binary_tree @ <<[[binary_tree_sub.f90]]>>= <> submodule (binary_tree) binary_tree_s use io_units 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 <> implicit none private <> <> <> 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 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 implicit none private <> <> <> interface <> end interface end module queue @ %def queue @ <<[[queue_sub.f90]]>>= <> submodule (queue) queue_s use, intrinsic :: iso_fortran_env, only: ERROR_UNIT 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 implicit none private <> <> interface <> end interface end module iterator @ %def iterator @ <<[[iterator_sub.f90]]>>= <> submodule (iterator) iterator_s use, intrinsic :: iso_fortran_env, only: ERROR_UNIT 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 8769) +++ trunk/src/physics/physics.nw (revision 8770) @@ -1,6864 +1,6882 @@ % -*- 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 <> <> <> <> contains <> end module physics_defs @ %def physics_defs @ \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 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) 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 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 <>= 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 <>= 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 <> end module c_particles @ %def c_particles @ <>= 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 <>= 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 c_particles <> <> <> <> <> <> <> contains <> end module lorentz @ %def lorentz @ \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 <>= 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 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 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) 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 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) 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 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) 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 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) 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) 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) 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) 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) 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 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 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 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 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 <>= 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 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 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 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 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 <>= 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 <>= 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) 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 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 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 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) 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 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) 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 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) 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 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) 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) 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) 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) 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) 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 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 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 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 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) 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 <>= 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 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 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 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 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 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 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) 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) 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) 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) 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) 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 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 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 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) 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 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 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) 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 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) 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 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) 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 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) 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 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) 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 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) 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 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) 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 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) 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 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) 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 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) 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 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) 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) & 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 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) 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 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 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 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) 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) 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 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 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 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 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 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 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 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 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 <>= 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 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 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 <>= 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 <>= 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 <>= 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 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 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 <>= 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 <>= 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 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) 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 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) 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 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 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 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) 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) 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) 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 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) 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 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) 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 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) 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) 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 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 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 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) 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 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 <>= 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 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) 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) 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <> <> <> <> contains <> end module phs_points @ %def phs_points @ \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 <>= 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 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 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) 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 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 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 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 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 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 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 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) 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 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 <> <> <> contains <> end module sm_physics @ %def sm_physics @ \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 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) real(default), intent(in) :: nf real(default) :: beta1 beta1 = 51.0_default - 19.0_default/three * nf end function beta1 pure 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) 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) 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) 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) 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) 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 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) 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 & (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 & (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, & k_q = (7.0_default/two - pi**2/6.0_default) * CF @ %def gamma_q @ <>= public :: gamma_g, 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 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 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 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 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 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 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 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 <>= 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) 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 <>= 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 <>= 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 <>= 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 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 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 <>= 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 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 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 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 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 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) 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 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) 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)) 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 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 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) 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 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 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 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 end function pqq @ %def pqq @ <>= public :: pgq <>= elemental function pgq (x) result (pgqx) real(kind=default), intent(in) :: x real(kind=default) :: pgqx pgqx = TR * (x**2 + (one - x)**2) end function pgq @ %def pgq @ <>= public :: pqg <>= elemental function pqg (x) result (pqgx) real(kind=default), intent(in) :: x real(kind=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 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 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 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 <>= function kbarqg (x) result (kbarqgx) real(kind=default), intent(in) :: x real(kind=default) :: kbarqgx kbarqgx = pqg(x) * log((one-x)/x) + CF * x end function kbarqg @ %def kbarqg @ <>= public :: kbargq <>= function kbargq (x) result (kbargqx) real(kind=default), intent(in) :: x real(kind=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 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 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 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 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 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 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 end function insert_q @ %def insert_q @ <>= public :: 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 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 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 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 @ %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 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 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 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 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 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 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 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 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 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 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 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 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) 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) 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 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 +<>= + 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 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 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 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 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 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 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 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 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 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 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 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 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 <> <> <> <> contains <> end module sm_qcd @ %def sm_qcd @ \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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <> <> <> <> contains <> end module sm_qed @ %def sm_qed @ \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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <> <> <> contains <> <> end module shower_algorithms @ %def shower_algorithms @ 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, & 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/qed_pdf/qed_pdf.nw =================================================================== --- trunk/src/qed_pdf/qed_pdf.nw (revision 8769) +++ trunk/src/qed_pdf/qed_pdf.nw (revision 8770) @@ -1,299 +1,297 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: QED ISR structure functions ("PDFs") %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{QED Parton Distribution Functions} \label{chap:qed_pdf} \includemodulegraph{qed_pdf} We start with a module that gives access to the ISR structure function: \begin{description} \item[electron\_pdfs] \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Electron PDFs} This module contains the formulae for the numerical evaluation of different incarnations of the QED initial-state radiation (ISR) structure functions (a.k.a. electron PDFs). <<[[electron_pdfs.f90]]>>= <> module electron_pdfs <> -<> <> <> <> <> interface <> end interface end module electron_pdfs @ %def electron_pdfs @ <>= use io_units @ %def electron_pdfs use @ <<[[electron_pdfs_sub.f90]]>>= <> submodule (electron_pdfs) electron_pdfs_s -<> <> <> use constants, only: pi use format_defs, only: FMT_19 use numeric_utils use sm_physics, only: Li2, zeta2, zeta3 contains <> end submodule electron_pdfs_s @ \subsection{The physics for electron beam PDFs (structure functions)} 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. Here, the form of $\epsilon$ results from the kinematical bounds for the momentum squared of the outgoing particle, which in the limit $m^2\ll s$ are given by \begin{align} t_0 &= -2\bar xE(E+p) + m^2 \approx -\bar x s, \\ t_1 &= -2\bar xE(E-p) + m^2 \approx x m^2, \end{align} so the integration over the propagator $1/(t-m^2)$ yields \begin{equation} \ln\frac{t_0-m^2}{t_1-m^2} = \ln\frac{s}{m^2}. \end{equation} The structure function has three parameters: $\alpha$, $m_{\rm in}$ of the incoming particle and $s$, the hard scale. Internally, we store the exponent $\epsilon$ which is the relevant parameter. (In conventional notation, $\epsilon=\beta/2$.) As defaults, we take the actual values of $\alpha$ (which is probably $\alpha(s)$), the actual mass $m_{\rm in}$ and the squared total c.m. energy $s$. Including $\epsilon$, $\epsilon^2$, and $\epsilon^3$ corrections, the successive approximation of the ISR structure function read \begin{align} f_0(x) &= \epsilon(1-x)^{-1+\epsilon} \\ f_1(x) &= g_1(\epsilon)\,f_0(x) - \frac{\epsilon}{2}(1+x) \\ \begin{split} f_2(x) &= g_2(\epsilon)\,f_0(x) - \frac{\epsilon}{2}(1+x) \\ &\quad - \frac{\epsilon^2}{8}\left( \frac{1+3x^2}{1-x}\ln x + 4(1+x) \ln(1-x) + 5 + x \right) \end{split} \\ \begin{split} f_3(x) &= g_3(\epsilon)\,f_0(x) - \frac{\epsilon}{2}(1+x) \\ &\quad - \frac{\epsilon^2}{8}\left( \frac{1+3x^2}{1-x}\ln x + 4(1+x) \ln(1-x) + 5 + x \right) \\ &\quad - \frac{\epsilon^3}{48}\left( \vphantom{\frac{1}{1-x}} (1+x)\left[6\mathop{\rm Li_2}(x) + 12\ln^2(1-x) - 3\pi^2\right]\right. + 6(x+5)\ln(1-x) \\ &\qquad\qquad + \frac{1}{1-x}\left[\frac32(1+8x+3x^2)\ln x + 12(1+x^2)\ln x\ln(1-x) \right. \\ &\qquad\qquad\qquad\qquad \left.\left. - \frac12(1+7x^2)\ln^2x + \frac14(39-24x-15x^2)\right] \vphantom{\frac{1}{1-x}} \right) \end{split} \end{align} where the successive approximations to the prefactor of the leading singularity \begin{equation} g(\epsilon) = \frac{\exp\left(\epsilon(-\gamma_E + \tfrac34)\right)} {\Gamma(1 + \epsilon)}, \end{equation} are given by \begin{align} g_0(\epsilon) &= 1 \\ g_1(\epsilon) &= 1 + \frac34\epsilon \\ g_2(\epsilon) &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 \\ g_3(\epsilon) &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 + \frac{27 - 24\pi^2 + 128 \zeta(3)}{384}\epsilon^3, \end{align} where, numerically \begin{equation} \zeta(3) = 1.20205690315959428539973816151\ldots \end{equation} Although one could calculate the function $g(\epsilon)$ exactly, truncating its Taylor expansion ensures the exact normalization of the truncated structure function at each given order: \begin{equation} \int_0^1 dx\,f_i(x) = 1 \qquad\text{for all $i$.} \end{equation} Effectively, the $O(\epsilon)$ correction reduces the low-$x$ tail of the structure function by $50\%$ while increasing the coefficient of the singularity by $O(\epsilon)$. Relative to this, the $O(\epsilon^2)$ correction slightly enhances $x>\frac12$ compared to $x<\frac12$. At $x=0$, $f_2(x)$ introduces a logarithmic singularity which should be cut off at $x_0=O(e^{-1/\epsilon})$: for lower $x$ the perturbative series breaks down. The $f_3$ correction is slightly positive for low $x$ values and negative near $x=1$, where the $\mathop{\rm Li_2}$ piece slightly softens the singularity at $x=1$. Instead of the definition for $\epsilon$ given above, it is customary to include a universal nonlogarithmic piece: \begin{equation} \epsilon = \frac{\alpha}{\pi}q_e^2\left(\ln\tfrac{s}{m^2} - 1\right) \end{equation} \subsection{Implementation} The basic type for lepton beam (QED) structure functions: <>= public :: qed_pdf_t <>= type :: qed_pdf_t private integer :: flv = 0 real(default) :: mass = 0 real(default) :: q_max = 0 real(default) :: alpha = 0 real(default) :: eps = 0 integer :: order contains <> end type qed_pdf_t @ %def qed_pdf_t @ <>= procedure :: init => qed_pdf_init <>= module subroutine qed_pdf_init & (qed_pdf, mass, alpha, charge, q_max, order) class(qed_pdf_t), intent(out) :: qed_pdf real(default), intent(in) :: mass, alpha, q_max, charge integer, intent(in) :: order end subroutine qed_pdf_init <>= module subroutine qed_pdf_init & (qed_pdf, mass, alpha, charge, q_max, order) class(qed_pdf_t), intent(out) :: qed_pdf real(default), intent(in) :: mass, alpha, q_max, charge integer, intent(in) :: order qed_pdf%mass = mass qed_pdf%q_max = q_max qed_pdf%alpha = alpha qed_pdf%order = order qed_pdf%eps = alpha/pi * charge**2 & * (2 * log (q_max / mass) - 1) end subroutine qed_pdf_init @ %def qed_pdf_init @ Write routine. <>= procedure :: write => qed_pdf_write <>= module subroutine qed_pdf_write (qed_pdf, unit) class(qed_pdf_t), intent(in) :: qed_pdf integer, intent(in), optional :: unit integer :: u end subroutine qed_pdf_write <>= module subroutine qed_pdf_write (qed_pdf, unit) class(qed_pdf_t), intent(in) :: qed_pdf integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A)") "QED structure function (PDF):" write (u, "(5x,A,I0)") "Flavor = ", qed_pdf%flv write (u, "(5x,A," // FMT_19 // ")") "Mass = ", qed_pdf%mass write (u, "(5x,A," // FMT_19 // ")") "q_max = ", qed_pdf%q_max write (u, "(5x,A," // FMT_19 // ")") "alpha = ", qed_pdf%alpha write (u, "(5x,A,I0)") "Order = ", qed_pdf%order write (u, "(5x,A," // FMT_19 // ")") "epsilon = ", qed_pdf%eps end subroutine qed_pdf_write @ %def qed_pdf_write @ For some unit tests, the order has to be set explicitly. <>= procedure :: set_order => qed_pdf_set_order <>= module subroutine qed_pdf_set_order (qed_pdf, order) class(qed_pdf_t), intent(inout) :: qed_pdf integer, intent(in) :: order end subroutine qed_pdf_set_order <>= module subroutine qed_pdf_set_order (qed_pdf, order) class(qed_pdf_t), intent(inout) :: qed_pdf integer, intent(in) :: order qed_pdf%order = order end subroutine qed_pdf_set_order @ %def qed_pdf_set_order @ Calculate the actual value depending on the order and a possible mapping parameter. <>= procedure :: evolve_qed_pdf => qed_pdf_evolve_qed_pdf <>= module subroutine qed_pdf_evolve_qed_pdf (qed_pdf, x, xb, rb, ff) class(qed_pdf_t), intent(inout) :: qed_pdf real(default), intent(in) :: x, xb, rb real(default), intent(inout) :: ff end subroutine qed_pdf_evolve_qed_pdf <>= module subroutine qed_pdf_evolve_qed_pdf (qed_pdf, x, xb, rb, ff) class(qed_pdf_t), intent(inout) :: qed_pdf real(default), intent(in) :: x, xb, rb real(default), intent(inout) :: ff real(default), parameter :: & & xmin = 0.00714053329734592839549879772019_default real(default), parameter :: & g1 = 3._default / 4._default, & g2 = (27 - 8 * pi**2) / 96._default, & g3 = (27 - 24 * pi**2 + 128 * zeta3) / 384._default real(default) :: x_2, log_x, log_xb if (ff > 0 .and. qed_pdf%order > 0) then ff = ff * (1 + g1 * qed_pdf%eps) x_2 = x * x if (rb > 0) ff = ff * (1 - (1-x_2) / (2 * rb)) if (qed_pdf%order > 1) then ff = ff * (1 + g2 * qed_pdf%eps**2) if (rb > 0 .and. xb > 0 .and. x > xmin) then log_x = log_prec (x, xb) log_xb = log_prec (xb, x) ff = ff * (1 - ((1 + 3 * x_2) * log_x + xb * (4 * (1 + x) * & log_xb + 5 + x)) / (8 * rb) * qed_pdf%eps) end if if (qed_pdf%order > 2) then ff = ff * (1 + g3 * qed_pdf%eps**3) if (rb > 0 .and. xb > 0 .and. x > xmin) then ff = ff * (1 - ((1 + x) * xb & * (6 * Li2(x) + 12 * log_xb**2 - 3 * pi**2) & + 1.5_default * (1 + 8 * x + 3 * x_2) * log_x & + 6 * (x + 5) * xb * log_xb & + 12 * (1 + x_2) * log_x * log_xb & - (1 + 7 * x_2) * log_x**2 / 2 & + (39 - 24 * x - 15 * x_2) / 4) & / (48 * rb) * qed_pdf%eps**2) end if end if end if end if end subroutine qed_pdf_evolve_qed_pdf @ %def qed_pdf_evolve_qed_pdf @