Index: trunk/src/utilities/utilities.nw =================================================================== --- trunk/src/utilities/utilities.nw (revision 8771) +++ trunk/src/utilities/utilities.nw (revision 8772) @@ -1,3652 +1,3662 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; noweb-code-mode: f90-mode -*- % WHIZARD code as NOWEB source: Utilities \chapter{Utilities} \includemodulegraph{utilities} These modules are intended as part of WHIZARD, but in fact they are generic and could be useful for any purpose. The modules depend only on modules from the [[basics]] set. \begin{description} \item[file\_utils] Procedures that deal with external files, if not covered by Fortran built-ins. \item[file\_registries] Manage files that are accessed by their name. \item[string\_utils] Some string-handling utilities. Includes conversion to C string. \item[format\_utils] Utilities for pretty-printing. \item[format\_defs] Predefined format strings. \item[numeric\_utils] Utilities for comparing numerical values. \item[data\_utils] Utitilies for data structures, i.e. a fixed size queue, polymorphic binary tree and dynamic array list. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{File Utilities} This module provides miscellaneous tools associated with named external files. Currently only: \begin{itemize} \item Delete a named file \end{itemize} <<[[file_utils.f90]]>>= <> module file_utils <> <> interface <> end interface end module file_utils @ %def file_utils <<[[file_utils_sub.f90]]>>= <> submodule (file_utils) file_utils_s - + use io_units + implicit none + contains <> end submodule file_utils_s @ %def file_utils_s @ \subsection{Deleting a file} Fortran does not contain a command for deleting a file. Here, we provide a subroutine that deletes a file if it exists. We do not handle the subtleties, so we assume that it is writable if it exists. <>= public :: delete_file <>= module subroutine delete_file (name) character(*), intent(in) :: name end subroutine delete_file <>= module subroutine delete_file (name) character(*), intent(in) :: name logical :: exist integer :: u inquire (file = name, exist = exist) if (exist) then u = free_unit () open (unit = u, file = name) close (u, status = "delete") end if end subroutine delete_file @ %def delete_file @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{File Registries} This module provides a file-registry facility. We can open and close files multiple times without inadvertedly accessing a single file by two different I/O unit numbers. Opening a file the first time enters it into the registry. Opening again just returns the associated I/O unit. The registry maintains a reference count, so closing a file does not actually complete until the last reference is released. File access will always be sequential, however. The file can't be opened at different positions simultaneously. <<[[file_registries.f90]]>>= <> module file_registries <> <> <> <> interface <> end interface end module file_registries @ %def file_registries @ <<[[file_registries_sub.f90]]>>= <> submodule (file_registries) file_registries_s use io_units + implicit none + contains <> end submodule file_registries_s @ \subsection{File handle} This object holds a filename (fully qualified), the associated unit, and a reference count. The idea is that the object should be deleted when the reference count drops to zero. <>= type :: file_handle_t type(string_t) :: file integer :: unit = 0 integer :: refcount = 0 contains <> end type file_handle_t @ %def file_handle_t @ Debugging output: <>= procedure :: write => file_handle_write <>= module subroutine file_handle_write (handle, u, show_unit) class(file_handle_t), intent(in) :: handle integer, intent(in) :: u logical, intent(in), optional :: show_unit end subroutine file_handle_write <>= module subroutine file_handle_write (handle, u, show_unit) class(file_handle_t), intent(in) :: handle integer, intent(in) :: u logical, intent(in), optional :: show_unit logical :: show_u show_u = .false.; if (present (show_unit)) show_u = show_unit if (show_u) then write (u, "(3x,A,1x,I0,1x,'(',I0,')')") & char (handle%file), handle%unit, handle%refcount else write (u, "(3x,A,1x,'(',I0,')')") & char (handle%file), handle%refcount end if end subroutine file_handle_write @ %def file_handle_write @ Initialize with a file name, don't open the file yet: <>= procedure :: init => file_handle_init <>= module subroutine file_handle_init (handle, file) class(file_handle_t), intent(out) :: handle type(string_t), intent(in) :: file end subroutine file_handle_init <>= module subroutine file_handle_init (handle, file) class(file_handle_t), intent(out) :: handle type(string_t), intent(in) :: file handle%file = file end subroutine file_handle_init @ %def file_handle_init @ We check the [[refcount]] before actually opening the file. <>= procedure :: open => file_handle_open <>= module subroutine file_handle_open (handle) class(file_handle_t), intent(inout) :: handle end subroutine file_handle_open <>= module subroutine file_handle_open (handle) class(file_handle_t), intent(inout) :: handle if (handle%refcount == 0) then handle%unit = free_unit () open (unit = handle%unit, file = char (handle%file), action = "read", & status = "old") end if handle%refcount = handle%refcount + 1 end subroutine file_handle_open @ %def file_handle_open @ Analogously, close if the refcount drops to zero. The caller may then delete the object. <>= procedure :: close => file_handle_close <>= module subroutine file_handle_close (handle) class(file_handle_t), intent(inout) :: handle end subroutine file_handle_close <>= module subroutine file_handle_close (handle) class(file_handle_t), intent(inout) :: handle handle%refcount = handle%refcount - 1 if (handle%refcount == 0) then close (handle%unit) handle%unit = 0 end if end subroutine file_handle_close @ %def file_handle_close @ The I/O unit will be nonzero when the file is open. <>= procedure :: is_open => file_handle_is_open <>= module function file_handle_is_open (handle) result (flag) class(file_handle_t), intent(in) :: handle logical :: flag end function file_handle_is_open <>= module function file_handle_is_open (handle) result (flag) class(file_handle_t), intent(in) :: handle logical :: flag flag = handle%unit /= 0 end function file_handle_is_open @ %def file_handle_is_open @ Return the filename, so we can identify the entry. <>= procedure :: get_file => file_handle_get_file <>= module function file_handle_get_file (handle) result (file) class(file_handle_t), intent(in) :: handle type(string_t) :: file end function file_handle_get_file <>= module function file_handle_get_file (handle) result (file) class(file_handle_t), intent(in) :: handle type(string_t) :: file file = handle%file end function file_handle_get_file @ %def file_handle_get_file @ For debugging, return the I/O unit number. <>= procedure :: get_unit => file_handle_get_unit <>= module function file_handle_get_unit (handle) result (unit) class(file_handle_t), intent(in) :: handle integer :: unit end function file_handle_get_unit <>= module function file_handle_get_unit (handle) result (unit) class(file_handle_t), intent(in) :: handle integer :: unit unit = handle%unit end function file_handle_get_unit @ %def file_handle_get_unit @ \subsection{File handles registry} This is implemented as a doubly-linked list. The list exists only once in the program, as a private module variable. Extend the handle type to become a list entry: <>= type, extends (file_handle_t) :: file_entry_t type(file_entry_t), pointer :: prev => null () type(file_entry_t), pointer :: next => null () end type file_entry_t @ %def file_entry_t @ The actual registry. We need only the pointer to the first entry. <>= public :: file_registry_t <>= type :: file_registry_t type(file_entry_t), pointer :: first => null () contains <> end type file_registry_t @ %def file_registry_t @ Debugging output. <>= procedure :: write => file_registry_write <>= module subroutine file_registry_write (registry, unit, show_unit) class(file_registry_t), intent(in) :: registry integer, intent(in), optional :: unit logical, intent(in), optional :: show_unit end subroutine file_registry_write <>= module subroutine file_registry_write (registry, unit, show_unit) class(file_registry_t), intent(in) :: registry integer, intent(in), optional :: unit logical, intent(in), optional :: show_unit type(file_entry_t), pointer :: entry integer :: u u = given_output_unit (unit) if (associated (registry%first)) then write (u, "(1x,A)") "File registry:" entry => registry%first do while (associated (entry)) call entry%write (u, show_unit) entry => entry%next end do else write (u, "(1x,A)") "File registry: [empty]" end if end subroutine file_registry_write @ %def file_registry_write @ Open a file: find the appropriate entry. Create a new entry and add to the list if necessary. The list is extended at the beginning. Return the I/O unit number for the records. <>= procedure :: open => file_registry_open <>= module subroutine file_registry_open (registry, file, unit) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file integer, intent(out), optional :: unit end subroutine file_registry_open <>= module subroutine file_registry_open (registry, file, unit) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file integer, intent(out), optional :: unit type(file_entry_t), pointer :: entry entry => registry%first FIND_ENTRY: do while (associated (entry)) if (entry%get_file () == file) exit FIND_ENTRY entry => entry%next end do FIND_ENTRY if (.not. associated (entry)) then allocate (entry) call entry%init (file) if (associated (registry%first)) then registry%first%prev => entry entry%next => registry%first end if registry%first => entry end if call entry%open () if (present (unit)) unit = entry%get_unit () end subroutine file_registry_open @ %def file_registry_open @ Close a file: find the appropriate entry. Delete the entry if there is no file connected to it anymore. <>= procedure :: close => file_registry_close <>= module subroutine file_registry_close (registry, file) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file end subroutine file_registry_close <>= module subroutine file_registry_close (registry, file) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file type(file_entry_t), pointer :: entry entry => registry%first FIND_ENTRY: do while (associated (entry)) if (entry%get_file () == file) exit FIND_ENTRY entry => entry%next end do FIND_ENTRY if (associated (entry)) then call entry%close () if (.not. entry%is_open ()) then if (associated (entry%prev)) then entry%prev%next => entry%next else registry%first => entry%next end if if (associated (entry%next)) then entry%next%prev => entry%prev end if deallocate (entry) end if end if end subroutine file_registry_close @ %def file_registry_close @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{String Utilities} This module provides tools associated with strings (built-in and variable). Currently: \begin{itemize} \item Upper and lower case for strings \item Convert to null-terminated C string \end{itemize} <<[[string_utils.f90]]>>= <> module string_utils use, intrinsic :: iso_c_binding <> <> <> <> <> interface <> end interface end module string_utils @ %def string_utils @ <<[[string_utils_sub.f90]]>>= <> submodule (string_utils) string_utils_s + implicit none + contains <> end submodule string_utils_s @ %def string_utils_s @ \subsection{Upper and Lower Case} These are, unfortunately, not part of Fortran. <>= public :: upper_case public :: lower_case <>= interface upper_case module procedure upper_case_char, upper_case_string end interface interface lower_case module procedure lower_case_char, lower_case_string end interface <>= module function upper_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string end function upper_case_char module function lower_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string end function lower_case_char module function upper_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string end function upper_case_string module function lower_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string end function lower_case_string <>= module function upper_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string integer :: pos, code integer, parameter :: offset = ichar('A')-ichar('a') do pos = 1, len (string) code = ichar (string(pos:pos)) select case (code) case (ichar('a'):ichar('z')) new_string(pos:pos) = char (code + offset) case default new_string(pos:pos) = string(pos:pos) end select end do end function upper_case_char module function lower_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string integer :: pos, code integer, parameter :: offset = ichar('a')-ichar('A') do pos = 1, len (string) code = ichar (string(pos:pos)) select case (code) case (ichar('A'):ichar('Z')) new_string(pos:pos) = char (code + offset) case default new_string(pos:pos) = string(pos:pos) end select end do end function lower_case_char module function upper_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string new_string = upper_case_char (char (string)) end function upper_case_string module function lower_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string new_string = lower_case_char (char (string)) end function lower_case_string @ %def upper_case lower_case @ \subsection{C-Fortran String Conversion} Convert a FORTRAN string to a null-terminated C string. <>= public :: string_f2c <>= interface string_f2c module procedure string_f2c_char, string_f2c_var_str end interface string_f2c <>= pure module function string_f2c_char (i) result (o) character(*), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o end function string_f2c_char pure module function string_f2c_var_str (i) result (o) type(string_t), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o end function string_f2c_var_str <>= pure module function string_f2c_char (i) result (o) character(*), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o o = i // c_null_char end function string_f2c_char pure module function string_f2c_var_str (i) result (o) type(string_t), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o o = char (i) // c_null_char end function string_f2c_var_str @ %def string_f2c @ The same task done by a subroutine, analogous to the C [[strcpy]] function. We append a null char and copy the characters to the output string, given by a character array -- which is equal to a [[c_char]] character string by the rule of sequence association. Note: Just like with the [[strcpy]] function, there is no bounds check. <>= public :: strcpy_f2c <>= module subroutine strcpy_f2c (fstring, cstring) character(*), intent(in) :: fstring character(c_char), dimension(*), intent(inout) :: cstring end subroutine strcpy_f2c <>= module subroutine strcpy_f2c (fstring, cstring) character(*), intent(in) :: fstring character(c_char), dimension(*), intent(inout) :: cstring integer :: i do i = 1, len (fstring) cstring(i) = fstring(i:i) end do cstring(len(fstring)+1) = c_null_char end subroutine strcpy_f2c @ %def strcpy_f2c @ Convert a null-terminated C string to a Fortran string. The C-string argument is sequence-associated to a one-dimensional array of C characters, where we do not know the dimension. To convert this to a [[string_t]] object, we need to assign it or to wrap it by another [[var_str]] conversion. <>= public :: string_c2f <>= module function string_c2f (cstring) result (fstring) character(c_char), dimension(*), intent(in) :: cstring character(:), allocatable :: fstring end function string_c2f <>= module function string_c2f (cstring) result (fstring) character(c_char), dimension(*), intent(in) :: cstring character(:), allocatable :: fstring integer :: i, n n = 0 do while (cstring(n+1) /= c_null_char) n = n + 1 end do allocate (character(n) :: fstring) do i = 1, n fstring(i:i) = cstring(i) end do end function string_c2f @ %def string_c2f @ \subsection{Number Conversion} Create a string from a number. We use fixed format for the reals and variable format for integers. <>= public :: str <>= interface str module procedure str_log, str_logs, str_int, str_ints, & str_real, str_reals, str_complex, str_complexs end interface <>= module function str_log (l) result (s) logical, intent(in) :: l type(string_t) :: s end function str_log module function str_logs (x) result (s) logical, dimension(:), intent(in) :: x type(string_t) :: s end function str_logs module function str_int (i) result (s) integer, intent(in) :: i type(string_t) :: s end function str_int module function str_ints (x) result (s) integer, dimension(:), intent(in) :: x type(string_t) :: s end function str_ints module function str_real (x) result (s) real(default), intent(in) :: x type(string_t) :: s end function str_real module function str_reals (x) result (s) real(default), dimension(:), intent(in) :: x type(string_t) :: s end function str_reals module function str_complex (x) result (s) complex(default), intent(in) :: x type(string_t) :: s end function str_complex module function str_complexs (x) result (s) complex(default), dimension(:), intent(in) :: x type(string_t) :: s end function str_complexs <>= module function str_log (l) result (s) logical, intent(in) :: l type(string_t) :: s if (l) then s = "True" else s = "False" end if end function str_log module function str_logs (x) result (s) logical, dimension(:), intent(in) :: x <> end function str_logs module function str_int (i) result (s) integer, intent(in) :: i type(string_t) :: s character(32) :: buffer write (buffer, "(I0)") i s = var_str (trim (adjustl (buffer))) end function str_int module function str_ints (x) result (s) integer, dimension(:), intent(in) :: x <> end function str_ints module function str_real (x) result (s) real(default), intent(in) :: x type(string_t) :: s character(32) :: buffer write (buffer, "(ES17.10)") x s = var_str (trim (adjustl (buffer))) end function str_real module function str_reals (x) result (s) real(default), dimension(:), intent(in) :: x <> end function str_reals module function str_complex (x) result (s) complex(default), intent(in) :: x type(string_t) :: s s = str_real (real (x)) // " + i " // str_real (aimag (x)) end function str_complex module function str_complexs (x) result (s) complex(default), dimension(:), intent(in) :: x <> end function str_complexs @ %def str <>= type(string_t) :: s integer :: i s = '[' do i = 1, size(x) - 1 s = s // str(x(i)) // ', ' end do s = s // str(x(size(x))) // ']' @ @ Auxiliary: Read real, integer, string value. <>= public :: read_rval public :: read_ival <>= module function read_rval (s) result (rval) real(default) :: rval type(string_t), intent(in) :: s end function read_rval module function read_ival (s) result (ival) integer :: ival type(string_t), intent(in) :: s end function read_ival <>= module function read_rval (s) result (rval) real(default) :: rval type(string_t), intent(in) :: s character(80) :: buffer buffer = s read (buffer, *) rval end function read_rval module function read_ival (s) result (ival) integer :: ival type(string_t), intent(in) :: s character(80) :: buffer buffer = s read (buffer, *) ival end function read_ival @ %def read_rval read_ival @ \subsection{String splitting} <>= public :: string_contains_word <>= pure module function string_contains_word & (str, word, include_identical) result (val) logical :: val type(string_t), intent(in) :: str, word logical, intent(in), optional :: include_identical end function string_contains_word <>= pure module function string_contains_word & (str, word, include_identical) result (val) logical :: val type(string_t), intent(in) :: str, word type(string_t) :: str_tmp, str_out logical, intent(in), optional :: include_identical logical :: yorn str_tmp = str val = .false. yorn = .false.; if (present (include_identical)) yorn = include_identical if (yorn) val = str == word call split (str_tmp, str_out, word) val = val .or. (str_out /= "") end function string_contains_word @ %def string_contains_word @ Create an array of strings using a separator. <>= public :: split_string <>= pure module subroutine split_string (str, separator, str_array) type(string_t), dimension(:), allocatable, intent(out) :: str_array type(string_t), intent(in) :: str, separator end subroutine split_string <>= pure module subroutine split_string (str, separator, str_array) type(string_t), dimension(:), allocatable, intent(out) :: str_array type(string_t), intent(in) :: str, separator type(string_t) :: str_tmp, str_out integer :: n_str n_str = 0; str_tmp = str do while (string_contains_word (str_tmp, separator)) n_str = n_str + 1 call split (str_tmp, str_out, separator) end do allocate (str_array (n_str)) n_str = 1; str_tmp = str do while (string_contains_word (str_tmp, separator)) call split (str_tmp, str_array (n_str), separator) n_str = n_str + 1 end do end subroutine split_string @ %def split_string @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Format Utilities} This module provides miscellaneous tools associated with formatting and pretty-printing. \begin{itemize} \item Horizontal separator lines in output \item Indenting an output line \item Formatting a number for \TeX\ output. \item Formatting a number for MetaPost output. \item Alternate numeric formats. \end{itemize} <<[[format_utils.f90]]>>= <> module format_utils <> <> <> <> interface <> end interface end module format_utils @ %def format_utils @ <<[[format_utils_sub.f90]]>>= <> submodule (format_utils) format_utils_s use string_utils, only: lower_case use io_units, only: given_output_unit - + + implicit none + contains <> end submodule format_utils_s @ %def format_utils_s @ \subsection{Line Output} Write a separator line. <>= public :: write_separator <>= module subroutine write_separator (u, mode) integer, intent(in) :: u integer, intent(in), optional :: mode end subroutine write_separator <>= module subroutine write_separator (u, mode) integer, intent(in) :: u integer, intent(in), optional :: mode integer :: m m = 1; if (present (mode)) m = mode select case (m) case default write (u, "(A)") repeat ("-", 72) case (1) write (u, "(A)") repeat ("-", 72) case (2) write (u, "(A)") repeat ("=", 72) end select end subroutine write_separator @ %def write_separator @ Indent the line with given number of blanks. <>= public :: write_indent <>= module subroutine write_indent (unit, indent) integer, intent(in) :: unit integer, intent(in), optional :: indent end subroutine write_indent <>= module subroutine write_indent (unit, indent) integer, intent(in) :: unit integer, intent(in), optional :: indent if (present (indent)) then write (unit, "(1x,A)", advance="no") repeat (" ", indent) end if end subroutine write_indent @ %def write_indent @ \subsection{Array Output} Write an array of integers. <>= public :: write_integer_array <>= module subroutine write_integer_array (array, unit, n_max, no_skip) integer, intent(in), dimension(:) :: array integer, intent(in), optional :: unit integer, intent(in), optional :: n_max logical, intent(in), optional :: no_skip end subroutine write_integer_array <>= module subroutine write_integer_array (array, unit, n_max, no_skip) integer, intent(in), dimension(:) :: array integer, intent(in), optional :: unit integer, intent(in), optional :: n_max logical, intent(in), optional :: no_skip integer :: u, i, n logical :: yorn u = given_output_unit (unit) yorn = .false.; if (present (no_skip)) yorn = no_skip if (present (n_max)) then n = n_max else n = size (array) end if do i = 1, n if (i < n .or. yorn) then write (u, "(I0, A)", advance = "no") array(i), ", " else write (u, "(I0)") array(i) end if end do end subroutine write_integer_array @ %def write_integer_array @ \subsection{\TeX-compatible Output} Quote underscore characters for use in \TeX\ output. <>= public :: quote_underscore <>= module function quote_underscore (string) result (quoted) type(string_t) :: quoted type(string_t), intent(in) :: string end function quote_underscore <>= module function quote_underscore (string) result (quoted) type(string_t) :: quoted type(string_t), intent(in) :: string type(string_t) :: part type(string_t) :: buffer buffer = string quoted = "" do call split (part, buffer, "_") quoted = quoted // part if (buffer == "") exit quoted = quoted // "\_" end do end function quote_underscore @ %def quote_underscore @ Format a number with $n$ significant digits for use in \TeX\ documents. <>= public :: tex_format <>= module function tex_format (rval, n_digits) result (string) type(string_t) :: string real(default), intent(in) :: rval integer, intent(in) :: n_digits end function tex_format <>= module function tex_format (rval, n_digits) result (string) type(string_t) :: string real(default), intent(in) :: rval integer, intent(in) :: n_digits integer :: e, n, w, d real(default) :: absval real(default) :: mantissa character :: sign character(20) :: format character(80) :: cstr n = min (abs (n_digits), 16) if (rval == 0) then string = "0" else absval = abs (rval) e = int (log10 (absval)) if (rval < 0) then sign = "-" else sign = "" end if select case (e) case (:-3) d = max (n - 1, 0) w = max (d + 2, 2) write (format, "('(F',I0,'.',I0,',A,I0,A)')") w, d mantissa = absval * 10._default ** (1 - e) write (cstr, fmt=format) mantissa, "\times 10^{", e - 1, "}" case (-2:0) d = max (n - e, 1 - e) w = max (d + e + 2, d + 2) write (format, "('(F',I0,'.',I0,')')") w, d write (cstr, fmt=format) absval case (1:2) d = max (n - e - 1, -e, 0) w = max (d + e + 2, d + 2, e + 2) write (format, "('(F',I0,'.',I0,')')") w, d write (cstr, fmt=format) absval case default d = max (n - 1, 0) w = max (d + 2, 2) write (format, "('(F',I0,'.',I0,',A,I0,A)')") w, d mantissa = absval * 10._default ** (- e) write (cstr, fmt=format) mantissa, "\times 10^{", e, "}" end select string = sign // trim (cstr) end if end function tex_format @ %def tex_format @ \subsection{Metapost-compatible Output} Write a number for use in Metapost code: <>= public :: mp_format <>= module function mp_format (rval) result (string) type(string_t) :: string real(default), intent(in) :: rval end function mp_format <>= module function mp_format (rval) result (string) type(string_t) :: string real(default), intent(in) :: rval character(16) :: tmp write (tmp, "(G16.8)") rval string = lower_case (trim (adjustl (trim (tmp)))) end function mp_format @ %def mp_format @ \subsection{Conditional Formatting} Conditional format string, intended for switchable numeric precision. <>= public :: pac_fmt <>= module subroutine pac_fmt (fmt, fmt_orig, fmt_pac, pacify) character(*), intent(in) :: fmt_orig, fmt_pac character(*), intent(out) :: fmt logical, intent(in), optional :: pacify end subroutine pac_fmt <>= module subroutine pac_fmt (fmt, fmt_orig, fmt_pac, pacify) character(*), intent(in) :: fmt_orig, fmt_pac character(*), intent(out) :: fmt logical, intent(in), optional :: pacify logical :: pacified pacified = .false. if (present (pacify)) pacified = pacify if (pacified) then fmt = fmt_pac else fmt = fmt_orig end if end subroutine pac_fmt @ %def pac_fmt @ \subsection{Guard tiny values} This function can be applied if values smaller than $10^{-99}$ would cause an underflow in the output format. We know that Fortran fixed-format can handle this by omitting the exponent letter, but we should expect non-Fortran or Fortran list-directed input, which would fail. We reset such values to $\pm 10^{-99}$, assuming that such tiny values would not matter, except for being non-zero. <>= public :: refmt_tiny <>= elemental module function refmt_tiny (val) result (trunc_val) real(default), intent(in) :: val real(default) :: trunc_val end function refmt_tiny <>= elemental module function refmt_tiny (val) result (trunc_val) real(default), intent(in) :: val real(default) :: trunc_val real(default), parameter :: tiny_val = 1.e-99_default if (val /= 0) then if (abs (val) < tiny_val) then trunc_val = sign (tiny_val, val) else trunc_val = val end if else trunc_val = val end if end function refmt_tiny @ %def refmt_tiny @ \subsection{Compressed output of integer arrays} <>= public :: write_compressed_integer_array <>= module subroutine write_compressed_integer_array (chars, array) character(len=*), intent(out) :: chars integer, intent(in), allocatable, dimension(:) :: array end subroutine write_compressed_integer_array <>= module subroutine write_compressed_integer_array (chars, array) character(len=*), intent(out) :: chars integer, intent(in), allocatable, dimension(:) :: array logical, dimension(:), allocatable :: used character(len=16) :: tmp type(string_t) :: string integer :: i, j, start_chain, end_chain chars = '[none]' string = "" if (allocated (array)) then if (size (array) > 0) then allocate (used (size (array))) used = .false. do i = 1, size (array) if (.not. used(i)) then start_chain = array(i) end_chain = array(i) used(i) = .true. EXTEND: do do j = 1, size (array) if (array(j) == end_chain + 1) then end_chain = array(j) used(j) = .true. cycle EXTEND end if if (array(j) == start_chain - 1) then start_chain = array(j) used(j) = .true. cycle EXTEND end if end do exit end do EXTEND if (end_chain - start_chain > 0) then write (tmp, "(I0,A,I0)") start_chain, "-", end_chain else write (tmp, "(I0)") start_chain end if string = string // trim (tmp) if (any (.not. used)) then string = string // ',' end if end if end do chars = string end if end if chars = adjustr (chars) end subroutine write_compressed_integer_array @ %def write_compressed_integer_array %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Format Definitions} This module provides named integer parameters that specify certain format strings, used for numerical output. <<[[format_defs.f90]]>>= <> module format_defs <> <> end module format_defs @ %def format_defs @ We collect format strings for various numerical output formats here. <>= character(*), parameter, public :: FMT_19 = "ES19.12" character(*), parameter, public :: FMT_18 = "ES18.11" character(*), parameter, public :: FMT_17 = "ES17.10" character(*), parameter, public :: FMT_16 = "ES16.9" character(*), parameter, public :: FMT_15 = "ES15.8" character(*), parameter, public :: FMT_14 = "ES14.7" character(*), parameter, public :: FMT_13 = "ES13.6" character(*), parameter, public :: FMT_12 = "ES12.5" character(*), parameter, public :: FMT_11 = "ES11.4" character(*), parameter, public :: FMT_10 = "ES10.3" @ %def FMT_10 FMT_11 FMT_12 FMT_13 FMT_14 @ %def FMT_15 FMT_16 FMT_17 FMT_18 FMT_19 @ Fixed-point formats for better readability, where appropriate. <>= character(*), parameter, public :: FMF_12 = "F12.9" @ %def FMF_12 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Numeric Utilities} <<[[numeric_utils.f90]]>>= <> module numeric_utils <> <> <> <> <> <> <> interface <> end interface end module numeric_utils @ %def numeric_utils @ <<[[numeric_utils_sub.f90]]>>= <> submodule (numeric_utils) numeric_utils_s use string_utils use constants use format_defs + implicit none + contains <> end submodule numeric_utils_s @ %def numeric_utils_s @ <>= public :: assert <>= module subroutine assert (unit, ok, description, exit_on_fail) integer, intent(in) :: unit logical, intent(in) :: ok character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail end subroutine assert <>= module subroutine assert (unit, ok, description, exit_on_fail) integer, intent(in) :: unit logical, intent(in) :: ok character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail logical :: ef ef = .false.; if (present (exit_on_fail)) ef = exit_on_fail if (.not. ok) then if (present(description)) then write (unit, "(A)") "* FAIL: " // description else write (unit, "(A)") "* FAIL: Assertion error" end if if (ef) stop 1 end if end subroutine assert @ %def assert @ Compare numbers and output error message if not equal. <>= public:: assert_equal interface assert_equal module procedure assert_equal_integer, assert_equal_integers, & assert_equal_real, assert_equal_reals, & assert_equal_complex, assert_equal_complexs end interface @ <>= module subroutine assert_equal_integer (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_integer <>= module subroutine assert_equal_integer (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = lhs == rhs desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_integer @ %def assert_equal_integer @ <>= module subroutine assert_equal_integers (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_integers <>= module subroutine assert_equal_integers (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = all(lhs == rhs) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_integers @ %def assert_equal_integers @ <>= module subroutine assert_equal_real (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_real <>= module subroutine assert_equal_real (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = nearly_equal (lhs, rhs, abs_smallness, rel_smallness) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_real @ %def assert_equal_real @ <>= module subroutine assert_equal_reals (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_reals <>= module subroutine assert_equal_reals (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = all(nearly_equal (lhs, rhs, abs_smallness, rel_smallness)) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_reals @ %def assert_equal_reals @ <>= module subroutine assert_equal_complex (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_complex <>= module subroutine assert_equal_complex (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = nearly_equal (real(lhs), real(rhs), abs_smallness, rel_smallness) & .and. nearly_equal (aimag(lhs), aimag(rhs), abs_smallness, rel_smallness) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_complex @ %def assert_equal_complex @ <>= module subroutine assert_equal_complexs (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_complexs <>= module subroutine assert_equal_complexs (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = all (nearly_equal (real(lhs), real(rhs), abs_smallness, rel_smallness)) & .and. all (nearly_equal (aimag(lhs), aimag(rhs), abs_smallness, rel_smallness)) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_complexs @ %def assert_equal_complexs @ Note that this poor man's check will be disabled if someone compiles with [[-ffast-math]] or similar optimizations. <>= elemental function ieee_is_nan (x) result (yorn) logical :: yorn real(default), intent(in) :: x yorn = (x /= x) end function ieee_is_nan @ %def ieee_is_nan @ This is still not perfect but should work in most cases. Usually one wants to compare to a relative epsilon [[rel_smallness]], except for numbers close to zero defined by [[abs_smallness]]. Both might need adaption to specific use cases but have reasonable defaults. <>= public :: nearly_equal <>= interface nearly_equal module procedure nearly_equal_real module procedure nearly_equal_complex end interface nearly_equal <>= elemental module function nearly_equal_real & (a, b, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness end function nearly_equal_real <>= elemental module function nearly_equal_real & (a, b, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness real(default) :: abs_a, abs_b, diff, abs_small, rel_small abs_a = abs (a) abs_b = abs (b) diff = abs (a - b) ! shortcut, handles infinities and nans if (a == b) then r = .true. return else if (ieee_is_nan (a) .or. ieee_is_nan (b) .or. ieee_is_nan (diff)) then r = .false. return end if abs_small = tiny_13; if (present (abs_smallness)) abs_small = abs_smallness rel_small = tiny_10; if (present (rel_smallness)) rel_small = rel_smallness if (abs_a < abs_small .and. abs_b < abs_small) then r = diff < abs_small else r = diff / max (abs_a, abs_b) < rel_small end if end function nearly_equal_real @ %def nearly_equal_real <>= elemental module function nearly_equal_complex & (a, b, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness end function nearly_equal_complex <>= elemental module function nearly_equal_complex & (a, b, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness r = nearly_equal_real (real (a), real (b), abs_smallness, rel_smallness) .and. & nearly_equal_real (aimag (a), aimag(b), abs_smallness, rel_smallness) end function nearly_equal_complex @ %def neary_equal_complex @ Often we will need to check whether floats vanish: <>= public:: vanishes interface vanishes module procedure vanishes_real, vanishes_complex end interface @ <>= elemental module function vanishes_real & (x, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness end function vanishes_real elemental module function vanishes_complex & (x, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness end function vanishes_complex <>= elemental module function vanishes_real & (x, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness r = nearly_equal (x, zero, abs_smallness, rel_smallness) end function vanishes_real elemental module function vanishes_complex & (x, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness r = vanishes_real (abs (x), abs_smallness, rel_smallness) end function vanishes_complex @ %def vanishes @ <>= public :: expanded_amp2 <>= pure module function expanded_amp2 (amp_tree, amp_blob) result (amp2) real(default) :: amp2 complex(default), dimension(:), intent(in) :: amp_tree, amp_blob end function expanded_amp2 <>= pure module function expanded_amp2 (amp_tree, amp_blob) result (amp2) real(default) :: amp2 complex(default), dimension(:), intent(in) :: amp_tree, amp_blob amp2 = sum (amp_tree * conjg (amp_tree) + & amp_tree * conjg (amp_blob) + & amp_blob * conjg (amp_tree)) end function expanded_amp2 @ %def expanded_amp2 @ <>= public :: abs2 <>= elemental module function abs2 (c) result (c2) real(default) :: c2 complex(default), intent(in) :: c end function abs2 <>= elemental module function abs2 (c) result (c2) real(default) :: c2 complex(default), intent(in) :: c c2 = real (c * conjg(c)) end function abs2 @ %def abs2 @ Remove element with [[index]] from array <>= public:: remove_array_element interface remove_array_element module procedure remove_array_element_logical end interface @ <>= module function remove_array_element_logical & (array, index) result (array_reduced) logical, intent(in), dimension(:) :: array integer, intent(in) :: index logical, dimension(:), allocatable :: array_reduced end function remove_array_element_logical <>= module function remove_array_element_logical & (array, index) result (array_reduced) logical, intent(in), dimension(:) :: array integer, intent(in) :: index logical, dimension(:), allocatable :: array_reduced integer :: i allocate (array_reduced(0)) do i = 1, size (array) if (i /= index) then array_reduced = [array_reduced, [array(i)]] end if end do end function remove_array_element_logical @ %def remove_array_element @ Remove all duplicates from an array of signed integers and returns an unordered array of remaining elements. This method does not really fit into this module. It could be part of a larger module which deals with array manipulations. <>= public :: remove_duplicates_from_int_array <>= module function remove_duplicates_from_int_array & (array) result (array_unique) integer, intent(in), dimension(:) :: array integer, dimension(:), allocatable :: array_unique end function remove_duplicates_from_int_array <>= module function remove_duplicates_from_int_array & (array) result (array_unique) integer, intent(in), dimension(:) :: array integer, dimension(:), allocatable :: array_unique integer :: i allocate (array_unique(0)) do i = 1, size (array) if (any (array_unique == array(i))) cycle array_unique = [array_unique, [array(i)]] end do end function remove_duplicates_from_int_array @ %def remove_duplicates_from_int_array @ <>= public :: extend_integer_array <>= module subroutine extend_integer_array (list, incr, initial_value) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: incr integer, intent(in), optional :: initial_value end subroutine extend_integer_array <>= module subroutine extend_integer_array (list, incr, initial_value) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: incr integer, intent(in), optional :: initial_value integer, dimension(:), allocatable :: list_store integer :: n, ini ini = 0; if (present (initial_value)) ini = initial_value n = size (list) allocate (list_store (n)) list_store = list deallocate (list) allocate (list (n+incr)) list(1:n) = list_store list(1+n : n+incr) = ini deallocate (list_store) end subroutine extend_integer_array @ %def extend_integer_array @ <>= public :: crop_integer_array <>= module subroutine crop_integer_array (list, i_crop) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: i_crop end subroutine crop_integer_array <>= module subroutine crop_integer_array (list, i_crop) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: i_crop integer, dimension(:), allocatable :: list_store allocate (list_store (i_crop)) list_store = list(1:i_crop) deallocate (list) allocate (list (i_crop)) list = list_store deallocate (list_store) end subroutine crop_integer_array @ %def crop_integer_array @ We also need an evaluation of $\log x$ which is stable near $x=1$. <>= public :: log_prec <>= module function log_prec (x, xb) result (lx) real(default), intent(in) :: x, xb real(default) :: lx end function log_prec <>= module function log_prec (x, xb) result (lx) real(default), intent(in) :: x, xb real(default) :: a1, a2, a3, lx a1 = xb a2 = a1 * xb / two a3 = a2 * xb * two / three if (abs (a3) < epsilon (a3)) then lx = - a1 - a2 - a3 else lx = log (x) end if end function log_prec @ %def log_prec @ <>= public :: split_array <>= interface split_array module procedure split_integer_array module procedure split_real_array end interface <>= module subroutine split_integer_array (list1, list2) integer, intent(inout), dimension(:), allocatable :: list1, list2 integer, dimension(:), allocatable :: list_store end subroutine split_integer_array module subroutine split_real_array (list1, list2) real(default), intent(inout), dimension(:), allocatable :: list1, list2 real(default), dimension(:), allocatable :: list_store end subroutine split_real_array <>= module subroutine split_integer_array (list1, list2) integer, intent(inout), dimension(:), allocatable :: list1, list2 integer, dimension(:), allocatable :: list_store allocate (list_store (size (list1) - size (list2))) list2 = list1(:size (list2)) list_store = list1 (size (list2) + 1:) deallocate (list1) allocate (list1 (size (list_store))) list1 = list_store deallocate (list_store) end subroutine split_integer_array module subroutine split_real_array (list1, list2) real(default), intent(inout), dimension(:), allocatable :: list1, list2 real(default), dimension(:), allocatable :: list_store allocate (list_store (size (list1) - size (list2))) list2 = list1(:size (list2)) list_store = list1 (size (list2) + 1:) deallocate (list1) allocate (list1 (size (list_store))) list1 = list_store deallocate (list_store) end subroutine split_real_array @ %def split_array @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \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 + implicit none + contains <> end submodule binary_tree_s @ %def binary_tree_s @ <>= public :: binary_tree_iterator_t <>= type :: binary_tree_iterator_t integer, dimension(:), allocatable :: key integer :: current !! current \in {1, N}. contains <> end type binary_tree_iterator_t @ %def binary_tree_iterator_t @ <>= type :: binary_tree_node_t integer :: height = 0 type(binary_tree_node_t), pointer :: left => null () type(binary_tree_node_t), pointer :: right => null () !! integer :: key = 0 class(*), pointer :: obj => null () contains <> end type binary_tree_node_t @ %def binary_tree_node_t @ <>= public :: binary_tree_t <>= type :: binary_tree_t integer :: n_elements = 0 type(binary_tree_node_t), pointer :: root => null () contains <> end type binary_tree_t @ %def binary_tree_t @ <>= procedure :: init => binary_tree_iterator_init <>= module subroutine binary_tree_iterator_init (iterator, btree) class(binary_tree_iterator_t), intent(inout) :: iterator type(binary_tree_t), target :: btree end subroutine binary_tree_iterator_init <>= !! We store all keys of the binary tree in an index array. !! Flatten the tree O(log n), each access is then O(1). !! However, accessing the corresponding object costs one O(log n). module subroutine binary_tree_iterator_init (iterator, btree) class(binary_tree_iterator_t), intent(inout) :: iterator type(binary_tree_t), target :: btree type(binary_tree_node_t), pointer :: node integer :: idx iterator%current = 1 allocate (iterator%key(btree%get_n_elements ()), source = 0) if (.not. btree%get_n_elements () > 0) return idx = 1; call fill_key (idx, iterator%key, btree%root) contains recursive subroutine fill_key (idx, key, node) integer, intent(inout) :: idx integer, dimension(:), intent(inout) :: key type(binary_tree_node_t), pointer :: node if (associated (node%left)) & call fill_key (idx, key, node%left) key(idx) = node%key idx = idx + 1 if (associated (node%right)) & call fill_key (idx, key, node%right) end subroutine fill_key end subroutine binary_tree_iterator_init @ %def binary_tree_iterator_init @ <>= procedure :: is_iterable => binary_tree_iterator_is_iterable <>= module function binary_tree_iterator_is_iterable (iterator) result (flag) class(binary_tree_iterator_t), intent(in) :: iterator logical :: flag end function binary_tree_iterator_is_iterable <>= module function binary_tree_iterator_is_iterable (iterator) result (flag) class(binary_tree_iterator_t), intent(in) :: iterator logical :: flag flag = iterator%current <= size (iterator%key) end function binary_tree_iterator_is_iterable @ %def binary_tree_iterator_is_handle @ <>= procedure :: next => binary_tree_iterator_next <>= module subroutine binary_tree_iterator_next (iterator, key) class(binary_tree_iterator_t), intent(inout) :: iterator integer, intent(out) :: key end subroutine binary_tree_iterator_next <>= module subroutine binary_tree_iterator_next (iterator, key) class(binary_tree_iterator_t), intent(inout) :: iterator integer, intent(out) :: key if (.not. iterator%is_iterable ()) then key = 0 else key = iterator%key(iterator%current) iterator%current = iterator%current + 1 end if end subroutine binary_tree_iterator_next @ %def binary_tree_iterator_next @ <>= procedure :: init => binary_tree_node_init <>= module subroutine binary_tree_node_init (btree_node, key, obj) class(binary_tree_node_t), intent(inout) :: btree_node integer, intent(in) :: key class(*), pointer :: obj end subroutine binary_tree_node_init <>= module subroutine binary_tree_node_init (btree_node, key, obj) class(binary_tree_node_t), intent(inout) :: btree_node integer, intent(in) :: key class(*), pointer :: obj btree_node%height = 1 btree_node%left => null () btree_node%right => null () btree_node%key = key btree_node%obj => obj end subroutine binary_tree_node_init @ %def binary_tree_node_init @ <>= procedure :: write => binary_tree_node_write <>= recursive module subroutine binary_tree_node_write & (btree_node, unit, level, mode) class(binary_tree_node_t), intent(in) :: btree_node integer, intent(in) :: unit integer, intent(in) :: level character(len=*), intent(in) :: mode end subroutine binary_tree_node_write <>= recursive module subroutine binary_tree_node_write & (btree_node, unit, level, mode) class(binary_tree_node_t), intent(in) :: btree_node integer, intent(in) :: unit integer, intent(in) :: level character(len=*), intent(in) :: mode character(len=24) :: fmt if (level > 0) then write (fmt, "(A,I3,A)") "(", 3 * level, "X,A,1X,I3,1X,I3,A)" else fmt = "(A,1X,I3,1X,I3,1X)" end if write (unit, fmt) mode, btree_node%key, btree_node%height ! write (unit, fmt) btree_node%key, btree_node%get_balance () if (associated (btree_node%right)) & call btree_node%right%write (unit, level = level + 1, mode = ">") if (associated (btree_node%left)) & call btree_node%left%write (unit, level = level + 1, mode = "<") end subroutine binary_tree_node_write @ %def binary_tree_node_write @ <>= procedure :: get_balance => binary_tree_node_get_balance <>= module function binary_tree_node_get_balance (btree_node) result (balance) class(binary_tree_node_t), intent(in) :: btree_node integer :: balance end function binary_tree_node_get_balance <>= module function binary_tree_node_get_balance (btree_node) result (balance) class(binary_tree_node_t), intent(in) :: btree_node integer :: balance integer :: leftHeight, rightHeight leftHeight = 0 rightHeight = 0 if (associated (btree_node%left)) leftHeight = btree_node%left%height if (associated (btree_node%right)) rightHeight = btree_node%right%height balance = leftHeight - rightHeight end function binary_tree_node_get_balance @ %def binary_tree_node_get_balance @ <>= procedure :: increment_height => binary_tree_node_increment_height <>= module subroutine binary_tree_node_increment_height (btree_node) class(binary_tree_node_t), intent(inout) :: btree_node end subroutine binary_tree_node_increment_height <>= module subroutine binary_tree_node_increment_height (btree_node) class(binary_tree_node_t), intent(inout) :: btree_node integer :: leftHeight, rightHeight leftHeight = 0 rightHeight = 0 if (associated (btree_node%left)) leftHeight = btree_node%left%height if (associated (btree_node%right)) rightHeight = btree_node%right%height btree_node%height = max (leftHeight, rightHeight) + 1 end subroutine binary_tree_node_increment_height @ %def binary_tree_node_increment_height @ <>= final :: binary_tree_node_final <>= !!! !!! NAG 7 compiler bug with finalizers and unlimited polymorphism !!! module subroutine binary_tree_node_final (btree_node) !!! type(binary_tree_node_t), intent(inout) :: btree_node !!! end subroutine binary_tree_node_final <>= recursive subroutine binary_tree_node_final (btree_node) type(binary_tree_node_t), intent(inout) :: btree_node if (associated (btree_node%left)) deallocate (btree_node%left) if (associated (btree_node%right)) deallocate (btree_node%right) deallocate (btree_node%obj) end subroutine binary_tree_node_final @ %def binary_tree_node_final @ <>= procedure :: write => binary_tree_write <>= module subroutine binary_tree_write (btree, unit) class(binary_tree_t), intent(in) :: btree integer, intent(in), optional :: unit end subroutine binary_tree_write <>= module subroutine binary_tree_write (btree, unit) class(binary_tree_t), intent(in) :: btree integer, intent(in), optional :: unit integer :: u u = given_output_unit(unit=unit) write (u, "(A,1X,I3)") "Number of elements", btree%n_elements if (associated (btree%root)) then call btree%root%write (u, level = 0, mode = "*") else write (u, "(A)") "Binary tree is empty." end if end subroutine binary_tree_write @ %def binary_tree_write @ <>= final :: binary_tree_final <>= !!! !!! NAG 7 compiler bug with finalizers and unlimited polymorphism !!! module subroutine binary_tree_final (btree) !!! type(binary_tree_t), intent(inout) :: btree !!! end subroutine binary_tree_final <>= subroutine binary_tree_final (btree) type(binary_tree_t), intent(inout) :: btree btree%n_elements = 0 if (associated (btree%root)) then deallocate (btree%root) end if end subroutine binary_tree_final @ %def binary_tree_final @ <>= procedure :: clear => binary_tree_clear <>= module subroutine binary_tree_clear (btree) class(binary_tree_t), intent(inout) :: btree end subroutine binary_tree_clear <>= module subroutine binary_tree_clear (btree) class(binary_tree_t), intent(inout) :: btree call binary_tree_final (btree) end subroutine binary_tree_clear @ %def binary_tree_clear @ <>= procedure :: get_n_elements => binary_tree_get_n_elements <>= module function binary_tree_get_n_elements (btree) result (n) class(binary_tree_t), intent(in) :: btree integer :: n end function binary_tree_get_n_elements <>= module function binary_tree_get_n_elements (btree) result (n) class(binary_tree_t), intent(in) :: btree integer :: n n = btree%n_elements end function binary_tree_get_n_elements @ %def binary_tree_get_n_elements @ <>= procedure :: insert => binary_tree_insert <>= module subroutine binary_tree_insert (btree, key, obj) class(binary_tree_t), intent(inout) :: btree integer, intent(in) :: key class(*), pointer, intent(in) :: obj end subroutine binary_tree_insert <>= module subroutine binary_tree_insert (btree, key, obj) class(binary_tree_t), intent(inout) :: btree integer, intent(in) :: key class(*), pointer, intent(in) :: obj type(binary_tree_node_t), pointer :: node allocate (node) call node%init (key, obj) btree%n_elements = btree%n_elements + 1 if (.not. associated (btree%root)) then btree%root => node else call btree%insert_node (btree%root, node) end if end subroutine binary_tree_insert @ %def binary_tree_import @ <>= procedure, private :: insert_node => binary_tree_insert_node <>= recursive module subroutine binary_tree_insert_node (btree, parent, node) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: parent type(binary_tree_node_t), intent(in), pointer :: node end subroutine binary_tree_insert_node <>= recursive module subroutine binary_tree_insert_node (btree, parent, node) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: parent type(binary_tree_node_t), intent(in), pointer :: node !! Choose left or right, if associated descend recursively into subtree, !! else insert node. if (node%key > parent%key) then if (associated (parent%right)) then call btree%insert_node (parent%right, node) else parent%right => node end if else if (node%key < parent%key) then if (associated (parent%left)) then call btree%insert_node (parent%left, node) else parent%left => node end if else write (*, "(A,1X,I0)") "Error: MUST not insert duplicate key", node%key stop 1 end if call parent%increment_height () call btree%balance (parent, node%key) end subroutine binary_tree_insert_node @ %def binary_tree_insert_node @ <>= procedure, private :: balance => binary_tree_balance <>= module subroutine binary_tree_balance (btree, subtree, key) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: subtree integer, intent(in) :: key end subroutine binary_tree_balance <>= !! Subtree: root of subtree (which is unbalance, refer to A in diagrams.) module subroutine binary_tree_balance (btree, subtree, key) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: subtree integer, intent(in) :: key type(binary_tree_node_t), pointer :: node, newNode integer :: balance balance = subtree%get_balance () node => subtree newNode => null () !! balance := h_left - h_right. !! Proof: balance > 0 => too many elements on the left side of the subtree. !! Proof: balance < 0 => too many elements on the right side of the subtree. if (balance > 1) then !! => left-side of subtree !! A3(2) B2(1) !! / / \ !! B2(1) C1(0) A1(0) !! / !! C1(0) !! !! A3(3) A1(2) C2(1) !! / / / \ !! B1(1) LEFT C2(1) RIGHT B1(0) A3(0) !! \ / !! C2(0) B1(0) if (subtree%left%key > key) then !! rotate right call btree%rotate_right (node, newNode) else !! subtree%left%key < key, rotate left, then right. call btree%rotate_left (node%left, newNode) node%left => newNode call btree%rotate_right (node, newNode) end if else if (balance < -1) then !! => right-side of subtree !! A0(2) B1(1) !! \ / \ !! B1(1) A1(0) C3(0) !! \ !! C3(0)* !! !! A1(2) A1(2) C2(1) !! \ \ / \ !! B3(1) RIGHT C2(1) LEFT A1(0) B3(0) !! / \ !! C2(0) B3(0) if (subtree%right%key < key) then !! rotate left call btree%rotate_left (node, newNode) else !! subtree%right%key > key, rotate right, then left. call btree%rotate_right (node%right, newNode) node%right => newNode call btree%rotate_left (node, newNode) end if end if if (associated (newNode)) subtree => newNode end subroutine binary_tree_balance @ %def binary_tree_balance @ <>= procedure :: search => binary_tree_search <>= module subroutine binary_tree_search (btree, key, obj) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key class(*), pointer, intent(out) :: obj end subroutine binary_tree_search <>= module subroutine binary_tree_search (btree, key, obj) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key class(*), pointer, intent(out) :: obj type(binary_tree_node_t), pointer :: current current => btree%root obj => null () if (.not. associated (current)) return do while (current%key /= key) if (current%key > key) then current => current%left else current => current%right end if if (.not. associated (current)) then !! Key not found. exit end if end do if (associated (current)) obj => current%obj end subroutine binary_tree_search @ %def binary_tree_search @ <>= procedure :: has_key => binary_tree_has_key <>= module function binary_tree_has_key (btree, key) result (flag) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key logical :: flag end function binary_tree_has_key <>= module function binary_tree_has_key (btree, key) result (flag) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key logical :: flag type(binary_tree_node_t), pointer :: current current => btree%root flag = .false. if (.not. associated (current)) return do while (current%key /= key) if (current%key > key) then current => current%left else current => current%right end if if (.not. associated (current)) then !! Key not found. return end if end do flag = .true. end function binary_tree_has_key @ %def binary_tree_has_key @ <>= procedure, private :: rotate_right => binary_tree_rotate_right <>= module subroutine binary_tree_rotate_right (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root end subroutine binary_tree_rotate_right <>= !! A Move B to A. !! / \ !! B E 1. Split B from A%left. !! / \ 2. Temporarily pointer to D. !! C D 3. Replace pointer to D by pointer to A - E. !! 4. Set temporary pointer to D to A%left. !! !! 1.+2. B T => D A !! / \ !! C E !! !! 3. B T => D !! / \ !! C A !! \ !! E !! !! 4. B !! / \ !! C A !! / \ !! D E !! !! \param[inout] root Root/parent root (A). !! \param[out] new_root New root/parent root (B). module subroutine binary_tree_rotate_right (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root type(binary_tree_node_t), pointer :: tmp new_root => root%left tmp => new_root%right new_root%right => root root%left => tmp call root%increment_height () call new_root%increment_height () end subroutine binary_tree_rotate_right @ %def binary_tree_rotate_right @ <>= procedure, private :: rotate_left => binary_tree_rotate_left <>= module subroutine binary_tree_rotate_left (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root end subroutine binary_tree_rotate_left <>= !! A Move B to A. !! / \ !! E B 1. Split B from A%left. !! / \ 2. Temporarily pointer to C. !! C D 3. Replace pointer to C by pointer to A - E. !! 4. Set temporary pointer to C to A%right. !! !! 1.+2. B T => C A !! \ / !! D E !! !! 3. B T => C !! / \ !! A D !! / !! E !! !! 4. B !! / \ !! A D !! / \ !! E C module subroutine binary_tree_rotate_left (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root type(binary_tree_node_t), pointer :: tmp new_root => root%right tmp => new_root%left new_root%left => root root%right => tmp call root%increment_height () call new_root%increment_height () end subroutine binary_tree_rotate_left @ %def binary_tree_rotate_left @ \subsection{Unit tests} \label{sec:unit-tests} <<[[binary_tree_ut.f90]]>>= <> module binary_tree_ut use unit_tests use binary_tree_uti <> <> contains <> end module binary_tree_ut @ %def binary_tree_ut @ <<[[binary_tree_uti.f90]]>>= <> module binary_tree_uti use binary_tree <> type :: btree_obj_t integer :: i = 0 end type btree_obj_t <> contains <> end module binary_tree_uti @ %def binary_tree_uti @ <>= public :: binary_tree_test <>= subroutine binary_tree_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine binary_tree_test @ %def binary_tree_test @ Provide testing for interface stability and correct implementation for the binary tree and its iterator. <>= call test (binary_tree_1, "binary_tree_1", & "check interface and implementation", & u, results) <>= public :: binary_tree_1 <>= subroutine binary_tree_1 (u) integer, intent(in) :: u integer, dimension(10) :: ndx = [1, 2, 5, 7, 19, 23, 97, -1, -6, 0] class(*), pointer :: obj type(binary_tree_t) :: btree type(binary_tree_iterator_t) :: iterator integer :: i, key write (u, "(A)") "* Test outout: Binary tree" write (u, "(A)") "* Purpose: test interface and implementation of binary tree " // & "and its iterator using polymorph objects." write (u, "(A)") write (u, "(A)") "* Insert fixed number of object into tree..." do i = 1, size (ndx) call allocate_obj (i, obj) call btree%insert (ndx(i), obj) end do write (u, "(A)") "* Search for all added objects in tree..." do i = size (ndx), 1, -1 write (u, "(A,1X,I3,1X,L1)") "- Has key", ndx(i), btree%has_key (ndx(i)) call btree%search (ndx(i), obj) select type (obj) type is (btree_obj_t) write (u, "(2(A,1X,I3,1X))") "- NDX", ndx(i), "OBJ", obj%i end select end do write (u, "(A)") "* Output binary tree in preorder..." call btree%write (u) write (u, "(A)") "* Clear binary tree..." call btree%clear () call btree%write (u) write (u, "(A)") "* Insert fixed number of object into tree (reversed order)..." do i = size (ndx), 1, -1 call allocate_obj (i, obj) call btree%insert (ndx(i), obj) end do write (u, "(A)") "* Iterate over binary tree..." call iterator%init (btree) do while (iterator%is_iterable ()) call iterator%next (key) call btree%search (key, obj) select type (obj) type is (btree_obj_t) write (u, "(2(A,1X,I3,1X))") "- KEY", key, "OBJ", obj%i end select end do write (u, "(A)") "* Search for a non-existing key..." write (u, "(A,1X,I3,1X,L1)") "- Has key", 123, btree%has_key (123) call btree%search (123, obj) write (u, "(A,1X,L1)") "- Object found", associated (obj) !! Do not test against a duplicate entry as the it will forcibly stop the program. contains subroutine allocate_obj (num, obj) integer, intent(in) :: num class(*), pointer, intent(out) :: obj allocate (btree_obj_t :: obj) select type (obj) type is (btree_obj_t) obj%i = num end select end subroutine allocate_obj end subroutine binary_tree_1 @ %def binary_tree_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Array List} <<[[array_list.f90]]>>= <> module array_list <> - 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 + implicit none + contains <> end submodule array_list_s @ %def array_list_s @ <>= integer, parameter :: ARRAY_LIST_START_SIZE = 10 real(default), parameter :: ARRAY_LIST_GROW_FACTOR = 1.5_default, & ARRAY_LIST_SHRINK_THRESHOLD = 0.3_default @ %def array_list_start_size array_list_grow_factor @ %def array_list_shrink_threshold @ <>= public :: array_list_t <>= type :: array_list_t private integer, dimension(:), allocatable :: array !! Track the index to *current* item, to be stored. !! Must fulfill: 0 <= count <= size. integer :: count = 0 !! size \in N. integer :: size = 0 contains <> end type array_list_t @ %def array_list_t @ <>= procedure :: write => array_list_write <>= module subroutine array_list_write (list, unit) class(array_list_t), intent(in) :: list integer, intent(in), optional :: unit end subroutine array_list_write <>= module subroutine array_list_write (list, unit) class(array_list_t), intent(in) :: list integer, intent(in), optional :: unit integer :: u u = ERROR_UNIT; if (present (unit)) u = unit write (u, "(A,2(1X,I3))") "COUNT / SIZE", list%count, list%size write (u, "(999(1X,I4))") list%array end subroutine array_list_write @ %def array_list_write @ <>= procedure :: init => array_list_init <>= module subroutine array_list_init (list) class(array_list_t), intent(out) :: list end subroutine array_list_init <>= module subroutine array_list_init (list) class(array_list_t), intent(out) :: list allocate (list%array(ARRAY_LIST_START_SIZE), source = 0) list%count = 0 list%size = ARRAY_LIST_START_SIZE end subroutine array_list_init @ %def array_list_init @ <>= procedure :: get => array_list_get <>= elemental module function array_list_get (list, index) result (data) class(array_list_t), intent(in) :: list integer, intent(in) :: index integer :: data end function array_list_get <>= elemental module function array_list_get (list, index) result (data) class(array_list_t), intent(in) :: list integer, intent(in) :: index integer :: data if (list%is_index (index)) then data = list%array(index) else data = 0 end if end function array_list_get @ %def array_list_get @ <>= procedure :: get_count => array_list_get_count <>= pure module function array_list_get_count (list) result (count) class(array_list_t), intent(in) :: list integer :: count end function array_list_get_count <>= pure module function array_list_get_count (list) result (count) class(array_list_t), intent(in) :: list integer :: count count = list%count end function array_list_get_count @ %def array_list_get_count @ <>= procedure :: get_size => array_list_get_size <>= pure module function array_list_get_size (list) result (size) class(array_list_t), intent(in) :: list integer :: size end function array_list_get_size <>= pure module function array_list_get_size (list) result (size) class(array_list_t), intent(in) :: list integer :: size size = list%size end function array_list_get_size @ %def array_list_get_size @ <>= procedure :: is_full => array_list_is_full <>= pure module function array_list_is_full (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag end function array_list_is_full <>= pure module function array_list_is_full (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag flag = list%count >= list%size end function array_list_is_full @ %def array_list_is_full @ <>= procedure :: is_empty => array_list_is_empty <>= pure module function array_list_is_empty (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag end function array_list_is_empty <>= pure module function array_list_is_empty (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag flag = .not. list%count > 0 end function array_list_is_empty @ %def array_list_is_empty @ <>= procedure :: is_index => array_list_is_index <>= pure module function array_list_is_index (list, index) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: index logical :: flag end function array_list_is_index <>= pure module function array_list_is_index (list, index) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: index logical :: flag flag = 0 < index .and. index <= list%count end function array_list_is_index @ %def array_list_is_index @ <>= procedure :: clear => array_list_clear <>= module subroutine array_list_clear (list) class(array_list_t), intent(inout) :: list end subroutine array_list_clear <>= module subroutine array_list_clear (list) class(array_list_t), intent(inout) :: list list%array = 0 list%count = 0 call list%shrink_size () end subroutine array_list_clear @ %def array_list_clear @ <>= procedure :: add => array_list_add <>= module subroutine array_list_add (list, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: data end subroutine array_list_add <>= module subroutine array_list_add (list, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: data list%count = list%count + 1 if (list%is_full ()) then call list%grow_size () end if list%array(list%count) = data end subroutine array_list_add @ %def array_list_add @ <>= procedure :: grow_size => array_list_grow_size <>= module subroutine array_list_grow_size (list) class(array_list_t), intent(inout) :: list end subroutine array_list_grow_size <>= module subroutine array_list_grow_size (list) class(array_list_t), intent(inout) :: list integer, dimension(:), allocatable :: array integer :: new_size if (.not. list%is_full ()) return new_size = int (list%size * ARRAY_LIST_GROW_FACTOR) allocate (array(new_size), source = 0) array(:list%size) = list%array call move_alloc (array, list%array) list%size = size (list%array) end subroutine array_list_grow_size @ %def array_list_grow_size @ <>= procedure :: shrink_size => array_list_shrink_size <>= module subroutine array_list_shrink_size (list) class(array_list_t), intent(inout) :: list integer, dimension(:), allocatable :: array end subroutine array_list_shrink_size <>= module subroutine array_list_shrink_size (list) class(array_list_t), intent(inout) :: list integer, dimension(:), allocatable :: array integer :: new_size !! Apply shrink threshold on count. ! if (.not. list%count > 0) return new_size = max (list%count, ARRAY_LIST_START_SIZE) allocate (array(new_size), source = 0) !! \note We have to circumvent the allocate-on-assignment, !! hence, we explicitly set the array boundaries. array(:list%count) = list%array(:list%count) call move_alloc (array, list%array) list%size = new_size end subroutine array_list_shrink_size @ %def array_list_shrink_size @ <>= procedure :: reverse_order => array_list_reverse_order <>= module subroutine array_list_reverse_order (list) class(array_list_t), intent(inout) :: list end subroutine array_list_reverse_order <>= module subroutine array_list_reverse_order (list) class(array_list_t), intent(inout) :: list list%array(:list%count) = list%array(list%count:1:-1) end subroutine array_list_reverse_order @ %def array_list_reverse_order @ <>= procedure :: sort => array_list_sort <>= pure module subroutine array_list_sort (list) class(array_list_t), intent(inout) :: list end subroutine array_list_sort <>= pure module subroutine array_list_sort (list) class(array_list_t), intent(inout) :: list if (list%is_empty ()) return call quick_sort (list%array(:list%count)) contains pure recursive subroutine quick_sort (array) integer, dimension(:), intent(inout) :: array integer :: pivot, tmp integer :: first, last integer i, j first = 1 last = size(array) pivot = array(int ((first+last) / 2.)) i = first j = last do do while (array(i) < pivot) i = i + 1 end do do while (pivot < array(j)) j = j - 1 end do if (i >= j) exit tmp = array(i) array(i) = array(j) array(j) = tmp i = i + 1 j = j - 1 end do if (first < i - 1) call quick_sort(array(first:i - 1)) if (j + 1 < last) call quick_sort(array(j + 1:last)) end subroutine quick_sort end subroutine array_list_sort @ %def array_list_sort @ <>= procedure :: is_element => array_list_is_element <>= pure module function array_list_is_element (list, data) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: data logical :: flag end function array_list_is_element <>= pure module function array_list_is_element (list, data) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: data logical :: flag if (list%is_empty ()) then flag = .false. else flag = any (data == list%array) end if end function array_list_is_element @ %def array_list_is_element @ <>= procedure :: find => array_list_find <>= module function array_list_find (list, data) result (index) class(array_list_t), intent(inout) :: list integer, intent(in) :: data integer :: index end function array_list_find <>= module function array_list_find (list, data) result (index) class(array_list_t), intent(inout) :: list integer, intent(in) :: data integer :: index if (list%is_empty () & .or. .not. list%is_element (data)) then index = 0 return end if call list%sort () !! INTENT(INOUT) index = binary_search_leftmost (list%array(:list%count), data) contains pure function binary_search_leftmost (array, data) result (index) integer, dimension(:), intent(in) :: array integer, intent(in) :: data integer :: index integer :: left, right left = 1 right = size (array) do while (left < right) index = floor ((left + right) / 2.) if (array(index) < data) then left = index + 1 else right = index end if end do index = left end function binary_search_leftmost end function array_list_find @ %def array_list_find @ <>= procedure :: add_at => array_list_add_at <>= module subroutine array_list_add_at (list, index, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer, intent(in) :: data end subroutine array_list_add_at <>= module subroutine array_list_add_at (list, index, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer, intent(in) :: data if (.not. list%is_index (index)) return if (list%is_full ()) then call list%grow_size () end if list%array(index + 1:list%count + 1) = list%array(index:list%count) list%array(index) = data list%count = list%count + 1 end subroutine array_list_add_at @ %def array_list_add_at @ <>= procedure :: remove => array_list_remove <>= module function array_list_remove (list) result (data) class(array_list_t), intent(inout) :: list integer :: data end function array_list_remove <>= module function array_list_remove (list) result (data) class(array_list_t), intent(inout) :: list integer :: data if (list%is_empty ()) then data = 0 return end if data = list%get (list%count) list%array(list%count) = 0 list%count = list%count -1 end function array_list_remove @ %def array_list_remove @ <>= procedure :: remove_at => array_list_remove_at <>= module function array_list_remove_at (list, index) result (data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer :: data end function array_list_remove_at <>= module function array_list_remove_at (list, index) result (data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer :: data if (list%is_empty ()) then data = 0 return end if data = list%get (index) list%array(index:list%count - 1) = list%array(index + 1:list%count) list%array(list%count) = 0 list%count = list%count - 1 end function array_list_remove_at @ %def array_list_remove_at @ \subsection{Unit tests} \label{sec:unit-tests} <<[[array_list_ut.f90]]>>= <> module array_list_ut use unit_tests use array_list_uti <> <> contains <> end module array_list_ut @ %def array_list_ut @ <<[[array_list_uti.f90]]>>= <> module array_list_uti use array_list <> <> contains <> end module array_list_uti @ %def array_list_uti @ <>= public :: array_list_test <>= subroutine array_list_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine array_list_test @ %def array_list_test @ Provide testing for interface stability and correct implementation for the binary tree and its iterator. <>= call test (array_list_1, "array_list_1", & "check interface and implementation", & u, results) <>= public :: array_list_1 <>= subroutine array_list_1 (u) integer, intent(in) :: u type(array_list_t) :: list integer :: ndx, data write (u, "(A)") "* Test output: Array list" write (u, "(A)") "* Purpose: test interface and implementation of array list" write (u, "(A)") write (u, "(A)") "* Init array_list_t ..." call list%init () write (u, "(A)") "* Test adding a single element..." call list%add (1) write (u, "(A)") "* Test removing a single element..." data = list%remove () write (u, "(A)") "* Test growing (unnecessary, so just return)..." call list%grow_size () write (u, "(A)") "* Test adding elements beyond initial capacity..." call test_grow_and_add (list) write (u, "(A)") "* Test adding at specific position..." call list%add_at (10, -1) write (u, "(A)") "* Test removing at specific position..." data = list%remove_at (11) write (u, "(A)") "* Test reverse ordering..." call list%reverse_order () write (u, "(A)") "* Test sorting..." call list%sort () write (u, "(A)") "* Test finding..." ndx = list%find (1) write (u, "(A)") "* Test shrinking..." call list%shrink_size () write (u, "(A)") "* Test get procedures..." call test_get_procedures (list) write (u, "(A)") "* Test clearing list..." call list%clear () write (u, "(A)") "* Test (more complicated) combinations:" write (u, "(A)") "* Test growing (necessary) during adding..." call test_grow_and_add (list) write (u, "(A)") "* Test adding random data and sorting..." call test_sort (list) write (u, "(A)") "* Test finding (before sorted)..." call test_find (list) contains subroutine test_get_procedures (list) type(array_list_t), intent(in) :: list integer :: n logical :: flag n = list%get(1) n = list%get_size () n = list%get_count () flag = list%is_element (1) end subroutine test_get_procedures subroutine test_grow_and_add (list) type(array_list_t), intent(inout) :: list integer :: i do i = 1, 2 * list%get_size () call list%add (i) end do end subroutine test_grow_and_add subroutine test_get (list) class(array_list_t), intent(inout) :: list integer :: i, data do i = list%get_count (), 1, -1 data = list%get (i) if (data == 0) then write (u, "(A,1X,I3)") "INDEX EMPTY", i end if end do end subroutine test_get subroutine test_sort (list) class(array_list_t), intent(inout) :: list call list%add (6) call list%add (2) call list%add (9) call list%add (4) call list%add (8) call list%add (7) call list%sort () end subroutine test_sort subroutine test_find (list) class(array_list_t), intent(inout) :: list write (u, "(A,1X,I3)") " 6 INDEX", list%find (6) write (u, "(A,1X,I3)") "-1 INDEX", list%find (-1) write (u, "(A,1X,I3)") " 3 INDEX", list%find (3) write (u, "(A,1X,I3)") "26 INDEX", list%find (26) call list%write (u) end subroutine test_find end subroutine array_list_1 @ %def array_list_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Queue} <<[[queue.f90]]>>= <> module queue - 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 + implicit none + contains <> end submodule queue_s @ %def queue_s @ <>= integer, parameter :: QUEUE_SIZE = 10, & QUEUE_START = 0, & QUEUE_END = QUEUE_SIZE @ %def queue_size queue_start queue_end @ <>= public :: queue_t <>= type :: queue_t private integer, dimension(QUEUE_SIZE) :: item integer :: front = 0 integer :: rear = 0 contains <> end type queue_t @ %def queue_t @ <>= procedure :: is_full => queue_is_full <>= elemental module function queue_is_full (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag end function queue_is_full <>= elemental module function queue_is_full (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag flag = queue%front == 1 .and. queue%rear == QUEUE_END end function queue_is_full @ %def queue_is_full @ <>= procedure :: is_empty => queue_is_empty <>= elemental module function queue_is_empty (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag end function queue_is_empty <>= elemental module function queue_is_empty (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag flag = queue%front == QUEUE_START end function queue_is_empty @ %def queue_is_empty @ <>= procedure :: enqueue => queue_enqueue <>= module subroutine queue_enqueue (queue, item) class(queue_t), intent(inout) :: queue integer, intent(in) :: item end subroutine queue_enqueue <>= module subroutine queue_enqueue (queue, item) class(queue_t), intent(inout) :: queue integer, intent(in) :: item if (queue%is_full ()) then !! Do something. else if (queue%front == QUEUE_START) queue%front = 1 queue%rear = queue%rear + 1 queue%item(queue%rear) = item end if end subroutine queue_enqueue @ %def queue_enqueue @ <>= procedure :: dequeue => queue_dequeue <>= module function queue_dequeue (queue) result (item) class(queue_t), intent(inout) :: queue integer :: item end function queue_dequeue <>= module function queue_dequeue (queue) result (item) class(queue_t), intent(inout) :: queue integer :: item if (queue%is_empty ()) then item = 0 else item = queue%item(queue%front) if (queue%front >= queue%rear) then queue%front = QUEUE_START queue%rear = QUEUE_START !! Q has only one element, !! so we reset the queue after deleting it. else queue%front = queue%front + 1 end if end if end function queue_dequeue @ %def queue_dequeue @ <>= procedure :: peek => queue_peek <>= module function queue_peek (queue) result (item) class(queue_t), intent(in) :: queue integer :: item end function queue_peek <>= module function queue_peek (queue) result (item) class(queue_t), intent(in) :: queue integer :: item if (queue%is_empty ()) then item = 0 else item = queue%item(queue%front) end if end function queue_peek @ %def queue_peek @ <>= procedure :: write => queue_write <>= module subroutine queue_write (queue, unit) class(queue_t), intent(in) :: queue integer, intent(in), optional :: unit end subroutine queue_write <>= module subroutine queue_write (queue, unit) class(queue_t), intent(in) :: queue integer, intent(in), optional :: unit integer :: u, i u = ERROR_UNIT; if (present (unit)) u = unit if (queue%is_empty ()) then write (u, *) "Empty Queue." else write (u, *) "Front ->", queue%front write (u, *) "Items ->" do i = 1, queue%rear write (u, *) queue%item(i) end do write (u, *) "Rear ->", queue%rear end if end subroutine queue_write @ %def queue_write @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Iterator} <<[[iterator.f90]]>>= <> module iterator - 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 + implicit none + contains <> end submodule iterator_s @ %def iterator_s @ <>= public :: iterator_t <>= !! Forward type :: iterator_t integer :: current = 0 integer :: begin = 0 integer :: end = 0 integer :: step = 1 contains <> end type iterator_t @ %def iterator_t @ <>= procedure :: write => iterator_write <>= module subroutine iterator_write (iter, unit) class(iterator_t), intent(in) :: iter integer, intent(in), optional :: unit end subroutine iterator_write <>= module subroutine iterator_write (iter, unit) class(iterator_t), intent(in) :: iter integer, intent(in), optional :: unit integer :: u u = ERROR_UNIT; if (present (unit)) u = unit write (u, "(3(A,1X,I3,1X))") "CURRENT", iter%current, & "BEGIN", iter%begin, "END", iter%end flush (u) end subroutine iterator_write @ %def iterator_write @ <>= procedure :: init => iterator_init <>= module subroutine iterator_init (iter, begin, end, step) class(iterator_t), intent(inout) :: iter integer, intent(in) :: begin integer, intent(in) :: end integer, intent(in), optional :: step end subroutine iterator_init <>= !! Proof: step > 0, begin < end. !! Proof: step < 0, begin > end. !! Proof: step /= 0. module subroutine iterator_init (iter, begin, end, step) class(iterator_t), intent(inout) :: iter integer, intent(in) :: begin integer, intent(in) :: end integer, intent(in), optional :: step iter%begin = begin iter%end = end iter%step = 1; if (present (step)) iter%step = step if (abs (iter%step) > 0) then iter%current = iter%begin else write (ERROR_UNIT, "(A)") "ERROR: Step size MUST be unequal to zero." stop 1 end if end subroutine iterator_init @ %def iterator_init @ <>= procedure :: at_begin => iterator_at_begin <>= pure module function iterator_at_begin (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag end function iterator_at_begin <>= pure module function iterator_at_begin (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag flag = iter%current == iter%begin end function iterator_at_begin @ %def iterator_at_begin @ <>= procedure :: at_end => iterator_at_end <>= pure module function iterator_at_end (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag end function iterator_at_end <>= pure module function iterator_at_end (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag flag = iter%current == iter%end end function iterator_at_end @ %def iterator_at_end @ <>= procedure :: is_iterable => iterator_is_iterable <>= pure module function iterator_is_iterable (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag end function iterator_is_iterable <>= !! Proof: begin < current < end pure module function iterator_is_iterable (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag if (iter%step > 0) then flag = iter%current <= iter%end else if (iter%step < 0) then flag = iter%current >= iter%end else flag = .false. end if end function iterator_is_iterable @ %def iterator_is_iterable @ <>= procedure :: next_step => iterator_next_step <>= module subroutine iterator_next_step (iter) class(iterator_t), intent(inout) :: iter end subroutine iterator_next_step <>= module subroutine iterator_next_step (iter) class(iterator_t), intent(inout) :: iter if (.not. iter%is_iterable ()) return iter%current = iter%current + iter%step end subroutine iterator_next_step @ %def iterator_next_step @ <>= procedure :: next => iterator_next <>= module function iterator_next (iter) result (ndx) class(iterator_t), intent(inout) :: iter integer :: ndx end function iterator_next <>= !! Proof: begin <= current <= end. !! However, after applying the step, this does not need to be true.. module function iterator_next (iter) result (ndx) class(iterator_t), intent(inout) :: iter integer :: ndx if (.not. iter%is_iterable ()) then ndx = 0 return end if ndx = iter%current iter%current = iter%current + iter%step end function iterator_next @ %def iterator_next @ <>= procedure :: get_current => iterator_get_current <>= pure module function iterator_get_current (iter) result (ndx) class(iterator_t), intent(in) :: iter integer :: ndx end function iterator_get_current <>= pure module function iterator_get_current (iter) result (ndx) class(iterator_t), intent(in) :: iter integer :: ndx if (.not. iter%is_iterable ()) then ndx = 0 return end if ndx = iter%current end function iterator_get_current @ %def iterator_get_current @ \subsection{Unit tests} \label{sec:unit-tests} <<[[iterator_ut.f90]]>>= <> module iterator_ut use unit_tests use iterator_uti <> <> contains <> end module iterator_ut @ %def iterator_ut @ <<[[iterator_uti.f90]]>>= <> module iterator_uti use iterator <> <> contains <> end module iterator_uti @ %def iterator_uti @ <>= public :: iterator_test <>= subroutine iterator_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine iterator_test @ %def iterator_test @ Provide testing for interface stability and correct implementation for the forward integer iterator. <>= call test (iterator_1, "iterator_1", & "check interface and implementation", & u, results) <>= public :: iterator_1 <>= subroutine iterator_1 (u) integer, intent(in) :: u type(iterator_t) :: iter write (u, "(A)") "* Test output: iterator_1" write (u, "(A)") "* Purpose: test interface and implementation of the forward integer iterator" write (u, "(A)") call iter%init (1, 10) call iter%write (u) do while (iter%is_iterable ()) write (u, "(A,1X,I3)") "NDX", iter%next () end do call iter%init (10, 1, -1) call iter%write (u) do while (iter%is_iterable ()) write (u, "(A,1X,I3)") "NDX", iter%next () end do write (u, "(A,1X,I3)") "INVALID NDX", iter%next () call iter%init (1, 10) call iter%write (u) do while (iter%is_iterable ()) call iter%next_step () write (u, "(A)") "STEP." end do end subroutine iterator_1 @ Index: trunk/src/system/system.nw =================================================================== --- trunk/src/system/system.nw (revision 8771) +++ trunk/src/system/system.nw (revision 8772) @@ -1,4860 +1,4868 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: system interfaces \chapter{System: Interfaces and Handlers} \includemodulegraph{system} Here, we collect modules that deal with the ``system'': operating-system interfaces, error handlers and diagnostics. \begin{description} \item[system\_defs] Constants relevant for the modules in this set. \item[diagnostics] Error and diagnostic message handling. Any messages and errors issued by WHIZARD functions are handled by the subroutines in this module, if possible. \item[os\_interface] Execute system calls, build and link external object files and libraries. \item[cputime] Timer data type and methods, for measuring performance. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Constants} The parameters here are used in various parts of the program, starting from the modules in the current chapter. Some of them may be modified if the need arises. <<[[system_defs.f90]]>>= <> module system_defs use, intrinsic :: iso_fortran_env, only: iostat_end, iostat_eor !NODEP! <> <> end module system_defs @ %def system_defs @ \subsection{Version} The version string is used for checking files. Note that the string length MUST NOT be changed, because reading binary files relies on it. <>= integer, parameter, public :: VERSION_STRLEN = 255 character(len=VERSION_STRLEN), parameter, public :: & & VERSION_STRING = "WHIZARD version <> (<>)" @ %def VERSION_STRLEN VERSION_STRING @ \subsection{Text Buffer} There is a hard limit on the line length which we should export. This buffer size is used both by the message handler, the lexer, and some further modules. <>= integer, parameter, public :: BUFFER_SIZE = 1000 @ %def BUFFER_SIZE @ \subsection{IOSTAT Codes} Defined in [[iso_fortran_env]], but we would like to use shorthands. <>= integer, parameter, public :: EOF = iostat_end, EOR = iostat_eor @ %def EOF EOR @ \subsection{Character Codes} Single-character constants. <>= character, parameter, public :: BLANK = ' ' character, parameter, public :: TAB = achar(9) character, parameter, public :: CR = achar(13) character, parameter, public :: LF = achar(10) character, parameter, public :: BACKSLASH = achar(92) @ %def BLANK TAB CR NL @ Character strings that indicate character classes. <>= character(*), parameter, public :: WHITESPACE_CHARS = BLANK// TAB // CR // LF character(*), parameter, public :: LCLETTERS = "abcdefghijklmnopqrstuvwxyz" character(*), parameter, public :: UCLETTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" character(*), parameter, public :: DIGITS = "0123456789" @ %def WHITESPACE_CHARS LCLETTERS UCLETTERS DIGITS @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{C wrapper for sigaction} This implements calls to [[sigaction]] and the appropriate signal handlers in C. The functionality is needed for the [[diagnostics]] module. <<[[signal_interface.c]]>>= /* <> */ #include #include extern int wo_sigint; extern int wo_sigterm; extern int wo_sigxcpu; extern int wo_sigxfsz; static void wo_handler_sigint (int sig) { wo_sigint = sig; } static void wo_handler_sigterm (int sig) { wo_sigterm = sig; } static void wo_handler_sigxcpu (int sig) { wo_sigxcpu = sig; } static void wo_handler_sigxfsz (int sig) { wo_sigxfsz = sig; } int wo_mask_sigint () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigint; return sigaction(SIGINT, &sa, NULL); } int wo_mask_sigterm () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigterm; return sigaction(SIGTERM, &sa, NULL); } int wo_mask_sigxcpu () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigxcpu; return sigaction(SIGXCPU, &sa, NULL); } int wo_mask_sigxfsz () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigxfsz; return sigaction(SIGXFSZ, &sa, NULL); } int wo_release_sigint () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGINT, &sa, NULL); } int wo_release_sigterm () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGTERM, &sa, NULL); } int wo_release_sigxcpu () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGXCPU, &sa, NULL); } int wo_release_sigxfsz () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGXFSZ, &sa, NULL); } @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{C wrapper for printf} The [[printf]] family of functions is implemented in C with an undefined number of arguments. This is not supported by the [[bind(C)]] interface. We therefore write wrappers for the versions of [[sprintf]] that we will actually use. This is used by the [[formats]] module. <<[[sprintf_interface.c]]>>= /* <> */ #include int sprintf_none(char* str, const char* format) { return sprintf(str, format); } int sprintf_int(char* str, const char* format, int val) { return sprintf(str, format, val); } int sprintf_double(char* str, const char* format, double val) { return sprintf(str, format, val); } int sprintf_str(char* str, const char* format, const char* val) { return sprintf(str, format, val); } <>= interface function sprintf_none (str, fmt) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt end function sprintf_none end interface interface function sprintf_int (str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt integer(c_int), value :: val end function sprintf_int end interface interface function sprintf_double (str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt real(c_double), value :: val end function sprintf_double end interface interface function sprintf_str(str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt character(c_char), dimension(*), intent(in) :: val end function sprintf_str end interface @ %def sprintf_int sprintf_double sprintf_str @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Error, Message and Signal Handling} We are not so ambitious as to do proper exception handling in [[WHIZARD]], but at least it may be useful to have a common interface for diagnostics: Results, messages, warnings, and such. As module variables we keep a buffer where the current message may be written to and a level indicator which tells which messages should be written on screen and which ones should be skipped. Alternatively, a string may be directly supplied to the message routine: this overrides the buffer, avoiding the necessety of formatted I/O in trivial cases. <<[[diagnostics.f90]]>>= <> module diagnostics use, intrinsic :: iso_c_binding !NODEP! <> <> use system_defs, only: BUFFER_SIZE, MAX_ERRORS <> <> <> <> <> <> interface <> end interface end module diagnostics <> @ %def diagnostics @ <<[[diagnostics_sub.f90]]>>= <> submodule (diagnostics) diagnostics_s use, intrinsic :: iso_fortran_env, only: output_unit !NODEP! use system_dependencies <> use string_utils, only: str use io_units + implicit none + contains <> end submodule diagnostics_s @ %def diagnostics_s @ Diagnostics levels: <>= public :: RESULT, DEBUG, DEBUG2 <>= integer, parameter :: TERMINATE=-2, BUG=-1, FATAL=1, & ERROR=2, WARNING=3, MESSAGE=4, RESULT=5, & DEBUG=6, DEBUG2=7 @ %def FATAL ERROR WARNING MESSAGE RESULT DEBUG DEBUG2 Diagnostics areas: <>= public :: d_area <>= interface d_area module procedure d_area_of_string module procedure d_area_to_string end interface <>= module function d_area_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string end function d_area_of_string elemental module function d_area_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i end function d_area_to_string <>= module function d_area_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string select case (char (string)) case ("particles") i = D_PARTICLES case ("events") i = D_EVENTS case ("shower") i = D_SHOWER case ("model_features") i = D_MODEL_F case ("matching") i = D_MATCHING case ("transforms") i = D_TRANSFORMS case ("subtraction") i = D_SUBTRACTION case ("virtual") i = D_VIRTUAL case ("threshold") i = D_THRESHOLD case ("phasespace") i = D_PHASESPACE case ("mismatch") i = D_MISMATCH case ("me_methods") i = D_ME_METHODS case ("process_integration") i = D_PROCESS_INTEGRATION case ("tauola") i = D_TAUOLA case ("core") i = D_CORE case ("vamp2") i = D_VAMP2 case ("mpi") i = D_MPI case ("qft") i = D_QFT case ("beams") i = D_BEAMS case ("real") i = D_REAL case ("flavor") i = D_FLAVOR case ("all") i = D_ALL case default print "(A)", "Possible values for --debug are:" do i = 0, D_LAST print "(A)", char (' ' // d_area_to_string(i)) end do call msg_fatal ("Please use one of the listed areas") end select end function d_area_of_string elemental module function d_area_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i select case (i) case (D_PARTICLES) string = "particles" case (D_EVENTS) string = "events" case (D_SHOWER) string = "shower" case (D_MODEL_F) string = "model_features" case (D_MATCHING) string = "matching" case (D_TRANSFORMS) string = "transforms" case (D_SUBTRACTION) string = "subtraction" case (D_VIRTUAL) string = "virtual" case (D_THRESHOLD) string = "threshold" case (D_PHASESPACE) string = "phasespace" case (D_MISMATCH) string = "mismatch" case (D_ME_METHODS) string = "me_methods" case (D_PROCESS_INTEGRATION) string = "process_integration" case (D_TAUOLA) string = "tauola" case (D_CORE) string = "core" case (D_VAMP2) string = "vamp2" case (D_MPI) string = "mpi" case (D_QFT) string = "qft" case (D_BEAMS) string = "beams" case (D_REAL) string = "real" case (D_FLAVOR) string = "flavor" case (D_ALL) string = "all" case default string = "undefined" end select end function d_area_to_string @ %def d_area @ <>= public :: D_PARTICLES, D_EVENTS, D_SHOWER, D_MODEL_F, & D_MATCHING, D_TRANSFORMS, D_SUBTRACTION, D_VIRTUAL, D_THRESHOLD, & D_PHASESPACE, D_MISMATCH, D_ME_METHODS, D_PROCESS_INTEGRATION, & D_TAUOLA, D_CORE, D_VAMP2, D_MPI, D_QFT, D_BEAMS, D_REAL, D_FLAVOR <>= integer, parameter :: D_ALL=0, D_PARTICLES=1, D_EVENTS=2, & D_SHOWER=3, D_MODEL_F=4, & D_MATCHING=5, D_TRANSFORMS=6, & D_SUBTRACTION=7, D_VIRTUAL=8, D_THRESHOLD=9, D_PHASESPACE=10, & D_MISMATCH=11, D_ME_METHODS=12, D_PROCESS_INTEGRATION=13, & D_TAUOLA=14, D_CORE=15, D_VAMP2 = 16, D_MPI = 17, D_QFT = 18, & D_BEAMS=19, D_REAL=20, D_FLAVOR=21, D_LAST=21 @ %def D_ALL D_PARTICLES D_EVENTS @ %def D_SHOWER D_MODEL_F D_MATCHING D_TRANSFORMS @ %def D_SUBTRACTION D_VIRTUAL D_THRESHOLD D_PHASESPACE @ %def D_MISMATCH D_ME_METHODS D_PROCESS_INTEGRATION @ %def D_TAUOLA D_CORE D_VAMP2 D_MPI D_QFT @ <>= public :: msg_level <>= integer, save, dimension(D_ALL:D_LAST) :: msg_level = RESULT @ %def msg_level @ <>= integer, parameter, public :: COL_UNDEFINED = -1 integer, parameter, public :: COL_GREY = 90, COL_PEACH = 91, COL_LIGHT_GREEN = 92, & COL_LIGHT_YELLOW = 93, COL_LIGHT_BLUE = 94, COL_PINK = 95, & COL_LIGHT_AQUA = 96, COL_PEARL_WHITE = 97, COL_BLACK = 30, & COL_RED = 31, COL_GREEN = 32, COL_YELLOW = 33, COL_BLUE = 34, & COL_PURPLE = 35, COL_AQUA = 36 @ %def COLORS @ <>= public :: set_debug_levels <>= module subroutine set_debug_levels (area_str) type(string_t), intent(in) :: area_str end subroutine set_debug_levels <>= module subroutine set_debug_levels (area_str) type(string_t), intent(in) :: area_str integer :: area if (.not. debug_on) call msg_fatal ("Debugging options & &can be used only if configured with --enable-fc-debug") area = d_area (area_str) if (area == D_ALL) then msg_level = DEBUG else msg_level(area) = DEBUG end if end subroutine set_debug_levels @ %def set_debug_levels @ <>= public :: set_debug2_levels <>= module subroutine set_debug2_levels (area_str) type(string_t), intent(in) :: area_str end subroutine set_debug2_levels <>= module subroutine set_debug2_levels (area_str) type(string_t), intent(in) :: area_str integer :: area if (.not. debug_on) call msg_fatal ("Debugging options & &can be used only if configured with --enable-fc-debug") area = d_area (area_str) if (area == D_ALL) then msg_level = DEBUG2 else msg_level(area) = DEBUG2 end if end subroutine set_debug2_levels @ %def set_debug2_levels @ <>= type :: terminal_color_t integer :: color = COL_UNDEFINED contains <> end type terminal_color_t @ %def terminal_color_t @ <>= public :: term_col <>= interface term_col module procedure term_col_int module procedure term_col_char end interface term_col @ %def term_col @ <>= module function term_col_int (col_int) result (color) type(terminal_color_t) :: color integer, intent(in) :: col_int end function term_col_int module function term_col_char (col_char) result (color) type(terminal_color_t) :: color character(len=*), intent(in) :: col_char end function term_col_char <>= module function term_col_int (col_int) result (color) type(terminal_color_t) :: color integer, intent(in) :: col_int color%color = col_int end function term_col_int module function term_col_char (col_char) result (color) type(terminal_color_t) :: color character(len=*), intent(in) :: col_char type(string_t) :: buf select case (col_char) case ('Grey') color%color = COL_GREY case ('Peach') color%color = COL_PEACH case ('Light Green') color%color = COL_LIGHT_GREEN case ('Light Yellow') color%color = COL_LIGHT_YELLOW case ('Light Blue') color%color = COL_LIGHT_BLUE case ('Pink') color%color = COL_PINK case ('Light Aqua') color%color = COL_LIGHT_AQUA case ('Pearl White') color%color = COL_PEARL_WHITE case ('Black') color%color = COL_BLACK case ('Red') color%color = COL_RED case ('Green') color%color = COL_GREEN case ('Yellow') color%color = COL_YELLOW case ('Blue') color%color = COL_BLUE case ('Purple') color%color = COL_PURPLE case ('Aqua') color%color = COL_AQUA case default buf = var_str ('Color ') // var_str (col_char) // var_str (' is not defined') call msg_warning (char (buf)) color%color = COL_UNDEFINED end select end function term_col_char @ %def term_col_int term_col_char @ Mask fatal errors so that are treated as normal errors. Useful for interactive mode. <>= public :: mask_fatal_errors <>= logical, save :: mask_fatal_errors = .false. @ %def mask_fatal_errors @ How to handle bugs and unmasked fatal errors. Either execute a normal stop statement, or call the C [[exit()]] function, or try to cause a program crash by dereferencing a null pointer. These procedures are appended to the [[diagnostics]] source code, but not as module procedures but as external procedures. This avoids a circular module dependency across source directories. <>= integer, parameter, public :: TERM_STOP = 0, TERM_EXIT = 1, TERM_CRASH = 2 @ %def TERM_STOP TERM_EXIT TERM_CRASH <>= public :: handle_fatal_errors <>= integer, save :: handle_fatal_errors = TERM_EXIT <>= subroutine fatal_force_crash () use diagnostics, only: handle_fatal_errors, TERM_CRASH !NODEP! implicit none handle_fatal_errors = TERM_CRASH end subroutine fatal_force_crash subroutine fatal_force_exit () use diagnostics, only: handle_fatal_errors, TERM_EXIT !NODEP! implicit none handle_fatal_errors = TERM_EXIT end subroutine fatal_force_exit subroutine fatal_force_stop () use diagnostics, only: handle_fatal_errors, TERM_STOP !NODEP! implicit none handle_fatal_errors = TERM_STOP end subroutine fatal_force_stop @ %def fatal_force_crash @ %def fatal_force_exit @ %def fatal_force_stop @ Keep track of errors. This might be used for exception handling, later. The counter is incremented only for screen messages, to avoid double counting. <>= public :: msg_count <>= integer, dimension(TERMINATE:WARNING), save :: msg_count = 0 @ %def msg_count @ Keep a list of all errors and warnings. Since we do not know the number of entries beforehand, we use a linked list. <>= type :: string_list character(len=BUFFER_SIZE) :: string type(string_list), pointer :: next end type string_list type :: string_list_pointer type(string_list), pointer :: first, last end type string_list_pointer @ %def string_list string_list_pointer <>= type(string_list_pointer), dimension(TERMINATE:WARNING), save :: & & msg_list = string_list_pointer (null(), null()) @ %def msg_list @ Create a format string indicating color @ Add the current message buffer contents to the internal list. <>= subroutine msg_add (level) integer, intent(in) :: level type(string_list), pointer :: message select case (level) case (TERMINATE:WARNING) allocate (message) message%string = msg_buffer nullify (message%next) if (.not.associated (msg_list(level)%first)) & & msg_list(level)%first => message if (associated (msg_list(level)%last)) & & msg_list(level)%last%next => message msg_list(level)%last => message msg_count(level) = msg_count(level) + 1 end select end subroutine msg_add @ %def msg_add @ Initialization: <>= public :: msg_list_clear <>= module subroutine msg_list_clear end subroutine msg_list_clear <>= module subroutine msg_list_clear integer :: level type(string_list), pointer :: message do level = TERMINATE, WARNING do while (associated (msg_list(level)%first)) message => msg_list(level)%first msg_list(level)%first => message%next deallocate (message) end do nullify (msg_list(level)%last) end do msg_count = 0 end subroutine msg_list_clear @ %def msg_list_clear @ Display the summary of errors and warnings (no need to count fatals\ldots) <>= public :: msg_summary <>= module subroutine msg_summary (unit) integer, intent(in), optional :: unit end subroutine msg_summary <>= module subroutine msg_summary (unit) integer, intent(in), optional :: unit call expect_summary (unit) 1 format (A,1x,I2,1x,A,I2,1x,A) if (msg_count(ERROR) > 0 .and. msg_count(WARNING) > 0) then write (msg_buffer, 1) "There were", & & msg_count(ERROR), "error(s) and ", & & msg_count(WARNING), "warning(s)." call msg_message (unit=unit) else if (msg_count(ERROR) > 0) then write (msg_buffer, 1) "There were", & & msg_count(ERROR), "error(s) and no warnings." call msg_message (unit=unit) else if (msg_count(WARNING) > 0) then write (msg_buffer, 1) "There were no errors and ", & & msg_count(WARNING), "warning(s)." call msg_message (unit=unit) end if end subroutine msg_summary @ %def msg_summary @ Print the list of all messages of a given level. <>= public :: msg_listing <>= module subroutine msg_listing (level, unit, prefix) integer, intent(in) :: level integer, intent(in), optional :: unit character(len=*), intent(in), optional :: prefix end subroutine msg_listing <>= module subroutine msg_listing (level, unit, prefix) integer, intent(in) :: level integer, intent(in), optional :: unit character(len=*), intent(in), optional :: prefix type(string_list), pointer :: message integer :: u u = given_output_unit (unit); if (u < 0) return if (present (unit)) u = unit message => msg_list(level)%first do while (associated (message)) if (present (prefix)) then write (u, "(A)") prefix // trim (message%string) else write (u, "(A)") trim (message%string) end if message => message%next end do flush (u) end subroutine msg_listing @ %def msg_listing @ The message buffer: <>= public :: msg_buffer <>= character(len=BUFFER_SIZE), save :: msg_buffer = " " @ %def msg_buffer @ After a message is issued, the buffer should be cleared: <>= subroutine buffer_clear msg_buffer = " " end subroutine buffer_clear @ %def buffer_clear <>= public :: create_col_string <>= module function create_col_string (color) result (col_string) type(string_t) :: col_string integer, intent(in) :: color end function create_col_string <>= module function create_col_string (color) result (col_string) type(string_t) :: col_string integer, intent(in) :: color character(2) :: buf write (buf, '(I2)') color col_string = var_str ("[") // var_str (buf) // var_str ("m") end function create_col_string @ %def create_col_string @ The generic handler for messages. If the unit is omitted (or $=6$), the message is written to standard output if the precedence if sufficiently high (as determined by the value of [[msg_level]]). If the string is omitted, the buffer is used. In any case, the buffer is cleared after printing. In accordance with FORTRAN custom, the first column in the output is left blank. For messages and warnings, an additional exclamation mark and a blank is prepended. Furthermore, each message is appended to the internal message list (without prepending anything). <>= subroutine message_print (level, string, str_arr, unit, logfile, area, color) integer, intent(in) :: level character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: str_arr integer, intent(in), optional :: unit logical, intent(in), optional :: logfile integer, intent(in), optional :: area integer, intent(in), optional :: color type(string_t) :: col_string, prep_string, aux_string, head_footer, app_string integer :: lu, i, ar logical :: severe, is_error ar = D_ALL; if (present (area)) ar = area severe = .false. head_footer = "******************************************************************************" aux_string = "" is_error = .false. app_string = "" select case (level) case (TERMINATE) prep_string = "" case (BUG) prep_string = "*** WHIZARD BUG: " aux_string = "*** " severe = .true. is_error = .true. case (FATAL) prep_string = "*** FATAL ERROR: " aux_string = "*** " severe = .true. is_error = .true. case (ERROR) prep_string = "*** ERROR: " aux_string = "*** " is_error = .true. case (WARNING) prep_string = "Warning: " case (MESSAGE) prep_string = "| " case (DEBUG, DEBUG2) prep_string = "D: " case default prep_string = "" end select if (present (color)) then if (color > COL_UNDEFINED) then col_string = create_col_string (color) prep_string = achar(27) // col_string // prep_string app_string = app_string // achar(27) // "[0m" end if end if if (present(string)) msg_buffer = string lu = log_unit if (present(unit)) then if (unit /= output_unit) then if (severe) write (unit, "(A)") char(head_footer) if (is_error) write (unit, "(A)") char(head_footer) write (unit, "(A,A,A)") char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) write (unit, "(A,A)") char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) write (unit, "(A)") char(head_footer) if (severe) write (unit, "(A)") char(head_footer) flush (unit) lu = -1 else if (level <= msg_level(ar)) then if (severe) print "(A)", char(head_footer) if (is_error) print "(A)", char(head_footer) print "(A,A,A)", char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) print "(A,A)", char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) print "(A)", char(head_footer) if (severe) print "(A)", char(head_footer) flush (output_unit) if (unit == log_unit) lu = -1 end if else if (level <= msg_level(ar)) then if (severe) print "(A)", char(head_footer) if (is_error) print "(A)", char(head_footer) print "(A,A,A)", char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) print "(A,A)", char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) print "(A)", char(head_footer) if (severe) print "(A)", char(head_footer) flush (output_unit) end if if (present (logfile)) then if (.not. logfile) lu = -1 end if if (logging .and. lu >= 0) then if (severe) write (lu, "(A)") char(head_footer) if (is_error) write (lu, "(A)") char(head_footer) write (lu, "(A,A,A)") char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) write (lu, "(A,A)") char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) write (lu, "(A)") char(head_footer) if (severe) write (lu, "(A)") char(head_footer) flush (lu) end if call msg_add (level) call buffer_clear end subroutine message_print @ %def message_print @ The number of non-fatal errors that we allow before stopping the program. We might trade this later for an adjustable number. <>= integer, parameter, public :: MAX_ERRORS = 10 @ %def MAX_ERRORS @ The specific handlers. In the case of fatal errors, bugs (failed assertions) and normal termination execution is stopped. For non-fatal errors a message is printed to standard output if no unit is given. Only if the number of [[MAX_ERRORS]] errors is reached, we abort the program. There are no further actions in the other cases, but this may change. <>= public :: msg_terminate public :: msg_bug, msg_fatal, msg_error, msg_warning public :: msg_message, msg_result <>= module subroutine msg_terminate (string, unit, quit_code) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string integer, intent(in), optional :: quit_code end subroutine msg_terminate module subroutine msg_bug (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr end subroutine msg_bug recursive module subroutine msg_fatal (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr end subroutine msg_fatal module subroutine msg_error (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr end subroutine msg_error module subroutine msg_warning (string, arr, unit, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr type(terminal_color_t), intent(in), optional :: color end subroutine msg_warning module subroutine msg_message (string, unit, arr, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color end subroutine msg_message module subroutine msg_result (string, arr, unit, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color end subroutine msg_result <>= module subroutine msg_terminate (string, unit, quit_code) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string integer, intent(in), optional :: quit_code integer(c_int) :: return_code call release_term_signals () if (present (quit_code)) then return_code = quit_code else return_code = 0 end if if (present (string)) & call message_print (MESSAGE, string, unit=unit) call msg_summary (unit) if (return_code == 0 .and. expect_failures /= 0) then return_code = 5 call message_print (MESSAGE, & "WHIZARD run finished with 'expect' failure(s).", unit=unit) else if (return_code == 7) then call message_print (MESSAGE, & "WHIZARD run finished with failed self-test.", unit=unit) else call message_print (MESSAGE, "WHIZARD run finished.", unit=unit) end if call message_print (0, & "|=============================================================================|", unit=unit) call logfile_final () call msg_list_clear () if (return_code /= 0) then call exit (return_code) else !!! Should implement WHIZARD exit code (currently only via C) call exit (0) end if end subroutine msg_terminate module subroutine msg_bug (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, pointer :: crash_ptr call message_print (BUG, string, arr, unit) call msg_summary (unit) select case (handle_fatal_errors) case (TERM_EXIT) call message_print (TERMINATE, "WHIZARD run aborted.", unit=unit) call exit (-1_c_int) case (TERM_CRASH) print *, "*** Intentional crash ***" crash_ptr => null () print *, crash_ptr end select stop "WHIZARD run aborted." end subroutine msg_bug recursive module subroutine msg_fatal (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, pointer :: crash_ptr if (mask_fatal_errors) then call msg_error (string, arr, unit) else call message_print (FATAL, string, arr, unit) call msg_summary (unit) select case (handle_fatal_errors) case (TERM_EXIT) call message_print (TERMINATE, "WHIZARD run aborted.", unit=unit) call exit (1_c_int) case (TERM_CRASH) print *, "*** Intentional crash ***" crash_ptr => null () print *, crash_ptr end select stop "WHIZARD run aborted." end if end subroutine msg_fatal module subroutine msg_error (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr call message_print (ERROR, string, arr, unit) if (msg_count(ERROR) >= MAX_ERRORS) then mask_fatal_errors = .false. call msg_fatal (" Too many errors encountered.") else if (.not.present(unit) .and. .not.mask_fatal_errors) then call message_print (MESSAGE, " (WHIZARD run continues)") end if end subroutine msg_error module subroutine msg_warning (string, arr, unit, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = WARNING, string = string, & str_arr = arr, unit = unit, color = cl) end subroutine msg_warning module subroutine msg_message (string, unit, arr, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = MESSAGE, & string = string, str_arr = arr, unit = unit, & logfile = logfile, color = cl) end subroutine msg_message module subroutine msg_result (string, arr, unit, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = RESULT, string = string, & str_arr = arr, unit = unit, logfile = logfile, color = cl) end subroutine msg_result @ %def msg_warning msg_message msg_result @ Debugging aids. Print messages or values of various kinds. All versions ultimately call [[msg_debug_none]], which in turn uses [[message_print]]. Safeguard: force crash if a routine (i.e., a debugging routine below) is called while the master switch [[debug_on]] is unset. Such calls should always be hidden behind [[if (debug_on)]], since they can significantly slow down the program. <>= if (.not. debug_on) call msg_bug ("msg_debug called with debug_on=.false.") @ The [[debug_on]] flag is provided by the [[debug_master]] module, and we can assume that it is a compile-time parameter. <>= public :: msg_debug <>= interface msg_debug module procedure msg_debug_none module procedure msg_debug_logical module procedure msg_debug_integer module procedure msg_debug_real module procedure msg_debug_complex module procedure msg_debug_string end interface <>= module subroutine msg_debug_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_none module subroutine msg_debug_logical (area, string, value, color) logical, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_logical module subroutine msg_debug_integer (area, string, value, color) integer, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_integer module subroutine msg_debug_real (area, string, value, color) real(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_real module subroutine msg_debug_complex (area, string, value, color) complex(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_complex module subroutine msg_debug_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug_string <>= module subroutine msg_debug_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color integer :: cl if (debug_active (area)) then cl = COL_BLUE; if (present (color)) cl = color%color call message_print (DEBUG, string, unit = output_unit, & area = area, logfile = .false., color = cl) else <> end if end subroutine msg_debug_none module subroutine msg_debug_logical (area, string, value, color) logical, intent(in) :: value <> end subroutine msg_debug_logical module subroutine msg_debug_integer (area, string, value, color) integer, intent(in) :: value <> end subroutine msg_debug_integer module subroutine msg_debug_real (area, string, value, color) real(default), intent(in) :: value <> end subroutine msg_debug_real module subroutine msg_debug_complex (area, string, value, color) complex(default), intent(in) :: value <> end subroutine msg_debug_complex module subroutine msg_debug_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color if (debug_active (area)) then call msg_debug_none (area, string // " = " // char (value), & color = color) else <> end if end subroutine msg_debug_string @ %def msg_debug <>= integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color character(len=64) :: buffer if (debug_active (area)) then write (buffer, *) value call msg_debug_none (area, string // " = " // trim (buffer), & color = color) else <> end if @ <>= public :: msg_print_color <>= interface msg_print_color module procedure msg_print_color_none module procedure msg_print_color_logical module procedure msg_print_color_integer module procedure msg_print_color_real end interface <>= module subroutine msg_print_color_none (string, color) character(len=*), intent(in) :: string !!!type(terminal_color_t), intent(in) :: color integer, intent(in) :: color end subroutine msg_print_color_none module subroutine msg_print_color_logical (string, value, color) character(len=*), intent(in) :: string logical, intent(in) :: value integer, intent(in) :: color end subroutine msg_print_color_logical module subroutine msg_print_color_integer (string, value, color) character(len=*), intent(in) :: string integer, intent(in) :: value integer, intent(in) :: color end subroutine msg_print_color_integer module subroutine msg_print_color_real (string, value, color) character(len=*), intent(in) :: string real(default), intent(in) :: value integer, intent(in) :: color end subroutine msg_print_color_real <>= module subroutine msg_print_color_none (string, color) character(len=*), intent(in) :: string !!!type(terminal_color_t), intent(in) :: color integer, intent(in) :: color call message_print (0, string, color = color) end subroutine msg_print_color_none module subroutine msg_print_color_logical (string, value, color) character(len=*), intent(in) :: string logical, intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_logical module subroutine msg_print_color_integer (string, value, color) character(len=*), intent(in) :: string integer, intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_integer module subroutine msg_print_color_real (string, value, color) character(len=*), intent(in) :: string real(default), intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_real @ %def msg_print_color_none, msg_print_color_logical @ %def msg_print_color_integer, msg_print_color_real @ Secondary debugging aids which implement more fine-grained debugging. Again, there is a safeguard against calling anything while [[debug_on=.false.]]. <>= if (.not. debug_on) call msg_bug ("msg_debug2 called with debug_on=.false.") <>= public :: msg_debug2 <>= interface msg_debug2 module procedure msg_debug2_none module procedure msg_debug2_logical module procedure msg_debug2_integer module procedure msg_debug2_real module procedure msg_debug2_complex module procedure msg_debug2_string end interface <>= module subroutine msg_debug2_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_none module subroutine msg_debug2_logical (area, string, value, color) logical, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_logical module subroutine msg_debug2_integer (area, string, value, color) integer, intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_integer module subroutine msg_debug2_real (area, string, value, color) real(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_real module subroutine msg_debug2_complex (area, string, value, color) complex(default), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_complex module subroutine msg_debug2_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color end subroutine msg_debug2_string <>= module subroutine msg_debug2_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color integer :: cl if (debug2_active (area)) then cl = COL_BLUE; if (present (color)) cl = color%color call message_print (DEBUG2, string, unit = output_unit, & area = area, logfile = .false., color = cl) else <> end if end subroutine msg_debug2_none module subroutine msg_debug2_logical (area, string, value, color) logical, intent(in) :: value <> end subroutine msg_debug2_logical module subroutine msg_debug2_integer (area, string, value, color) integer, intent(in) :: value <> end subroutine msg_debug2_integer module subroutine msg_debug2_real (area, string, value, color) real(default), intent(in) :: value <> end subroutine msg_debug2_real module subroutine msg_debug2_complex (area, string, value, color) complex(default), intent(in) :: value <> end subroutine msg_debug2_complex module subroutine msg_debug2_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color if (debug2_active (area)) then call msg_debug2_none (area, string // " = " // char (value), & color = color) else <> end if end subroutine msg_debug2_string @ %def msg_debug2 <>= integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color character(len=64) :: buffer if (debug2_active (area)) then write (buffer, *) value call msg_debug2_none (area, string // " = " // trim (buffer), & color = color) else <> end if @ <>= public :: debug_active <>= elemental module function debug_active (area) result (active) logical :: active integer, intent(in) :: area end function debug_active <>= elemental module function debug_active (area) result (active) logical :: active integer, intent(in) :: area active = debug_on .and. msg_level(area) >= DEBUG end function debug_active @ %def debug_active @ <>= public :: debug2_active <>= elemental module function debug2_active (area) result (active) logical :: active integer, intent(in) :: area end function debug2_active <>= elemental module function debug2_active (area) result (active) logical :: active integer, intent(in) :: area active = debug_on .and. msg_level(area) >= DEBUG2 end function debug2_active @ %def debug2_active @ Show the progress of a loop in steps of 10 \%. Could be generalized to other step sizes with an optional argument. <>= public :: msg_show_progress <>= module subroutine msg_show_progress (i_call, n_calls) integer, intent(in) :: i_call, n_calls end subroutine msg_show_progress <>= module subroutine msg_show_progress (i_call, n_calls) integer, intent(in) :: i_call, n_calls real(default) :: progress integer, save :: next_check if (i_call == 1) next_check = 10 progress = (i_call * 100._default) / n_calls if (progress >= next_check) then write (msg_buffer, "(F5.1,A)") progress, "%" call msg_message () next_check = next_check + 10 end if end subroutine msg_show_progress @ %def msg_show_progress @ Interface to the standard clib exit function <>= public :: exit <>= interface subroutine exit (status) bind (C) use iso_c_binding !NODEP! integer(c_int), value :: status end subroutine exit end interface @ %def exit @ Print the WHIZARD banner: <>= public :: msg_banner <>= module subroutine msg_banner (unit) integer, intent(in), optional :: unit end subroutine msg_banner <>= module subroutine msg_banner (unit) integer, intent(in), optional :: unit call message_print (0, "|=============================================================================|", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| WW WW WW WW WW WWWWWW WW WWWWW WWWW |", unit=unit) call message_print (0, "| WW WW WW WW WW WW WW WWWW WW WW WW WW |", unit=unit) call message_print (0, "| WW WW WW WW WWWWWWW WW WW WW WW WWWWW WW WW |", unit=unit) call message_print (0, "| WWWW WWWW WW WW WW WW WWWWWWWW WW WW WW WW |", unit=unit) call message_print (0, "| WW WW WW WW WW WWWWWW WW WW WW WW WWWW |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| W |", unit=unit) call message_print (0, "| sW |", unit=unit) call message_print (0, "| WW |", unit=unit) call message_print (0, "| sWW |", unit=unit) call message_print (0, "| WWW |", unit=unit) call message_print (0, "| wWWW |", unit=unit) call message_print (0, "| wWWWW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| wWW WW |", unit=unit) call message_print (0, "| wWW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| wwwwww WW WW |", unit=unit) call message_print (0, "| WWWWWww WW WW |", unit=unit) call message_print (0, "| WWWWWwwwww WW WW |", unit=unit) call message_print (0, "| wWWWwwwwwWW WW |", unit=unit) call message_print (0, "| wWWWWWWWWWWwWWW WW |", unit=unit) call message_print (0, "| wWWWWW wW WWWWWWW |", unit=unit) call message_print (0, "| WWWW wW WW wWWWWWWWwww |", unit=unit) call message_print (0, "| WWWW wWWWWWWWwwww |", unit=unit) call message_print (0, "| WWWW WWWW WWw |", unit=unit) call message_print (0, "| WWWWww WWWW |", unit=unit) call message_print (0, "| WWWwwww WWWW |", unit=unit) call message_print (0, "| wWWWWwww wWWWWW |", unit=unit) call message_print (0, "| WwwwwwwwwWWW |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| by: Wolfgang Kilian, Thorsten Ohl, Juergen Reuter |", unit=unit) call message_print (0, "| with contributions from Christian Speckner |", unit=unit) call message_print (0, "| Contact: |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| if you use WHIZARD please cite: |", unit=unit) call message_print (0, "| W. Kilian, T. Ohl, J. Reuter, Eur.Phys.J.C71 (2011) 1742 |", unit=unit) call message_print (0, "| [arXiv: 0708.4233 [hep-ph]] |", unit=unit) call message_print (0, "| M. Moretti, T. Ohl, J. Reuter, arXiv: hep-ph/0102195 |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "|=============================================================================|", unit=unit) call message_print (0, "| WHIZARD " // WHIZARD_VERSION, unit=unit) call message_print (0, "|=============================================================================|", unit=unit) end subroutine msg_banner @ %def msg_banner @ \subsection{Logfile} All screen output should be duplicated in the logfile, unless requested otherwise. <>= public :: logging <>= integer, save :: log_unit = -1 logical, target, save :: logging = .false. <>= public :: logfile_init <>= module subroutine logfile_init (filename) type(string_t), intent(in) :: filename end subroutine logfile_init <>= module subroutine logfile_init (filename) type(string_t), intent(in) :: filename call msg_message ("Writing log to '" // char (filename) // "'") if (.not. logging) call msg_message ("(Logging turned off.)") log_unit = free_unit () open (file = char (filename), unit = log_unit, & action = "write", status = "replace") end subroutine logfile_init @ %def logfile_init <>= public :: logfile_final <>= module subroutine logfile_final () end subroutine logfile_final <>= module subroutine logfile_final () if (log_unit >= 0) then close (log_unit) log_unit = -1 end if end subroutine logfile_final @ %def logfile_final @ This returns the valid logfile unit only if the default is write to screen, and if [[logfile]] is not set false. <>= public :: logfile_unit <>= module function logfile_unit (unit, logfile) integer :: logfile_unit integer, intent(in), optional :: unit logical, intent(in), optional :: logfile end function logfile_unit <>= module function logfile_unit (unit, logfile) integer :: logfile_unit integer, intent(in), optional :: unit logical, intent(in), optional :: logfile if (logging) then if (present (unit)) then if (unit == output_unit) then logfile_unit = log_unit else logfile_unit = -1 end if else if (present (logfile)) then if (logfile) then logfile_unit = log_unit else logfile_unit = -1 end if else logfile_unit = log_unit end if else logfile_unit = -1 end if end function logfile_unit @ %def logfile_unit @ \subsection{Checking values} The [[expect]] function does not just check a value for correctness (actually, it checks if a logical expression is true); it records its result here. If failures are present when the program terminates, the exit code is nonzero. <>= integer, save :: expect_total = 0 integer, save :: expect_failures = 0 @ %def expect_total expect_failures <>= public :: expect_record <>= module subroutine expect_record (success) logical, intent(in) :: success end subroutine expect_record <>= module subroutine expect_record (success) logical, intent(in) :: success expect_total = expect_total + 1 if (.not. success) expect_failures = expect_failures + 1 end subroutine expect_record @ %def expect_record <>= public :: expect_clear <>= module subroutine expect_clear () end subroutine expect_clear <>= module subroutine expect_clear () expect_total = 0 expect_failures = 0 end subroutine expect_clear @ %def expect_clear <>= public :: expect_summary <>= module subroutine expect_summary (unit, force) integer, intent(in), optional :: unit logical, intent(in), optional :: force end subroutine expect_summary <>= module subroutine expect_summary (unit, force) integer, intent(in), optional :: unit logical, intent(in), optional :: force logical :: force_output force_output = .false.; if (present (force)) force_output = force if (expect_total /= 0 .or. force_output) then call msg_message ("Summary of value checks:", unit) write (msg_buffer, "(2x,A,1x,I0,1x,A,1x,A,1x,I0)") & "Failures:", expect_failures, "/", "Total:", expect_total call msg_message (unit=unit) end if end subroutine expect_summary @ %def expect_summary @ Helpers for converting integers into strings with minimal length. <>= public :: int2string public :: int2char public :: int2fixed <>= pure module function int2fixed (i) result (c) integer, intent(in) :: i character(200) :: c end function int2fixed pure module function int2string (i) result (s) integer, intent(in) :: i type (string_t) :: s end function int2string pure module function int2char (i) result (c) integer, intent(in) :: i character(len (trim (int2fixed (i)))) :: c end function int2char <>= pure module function int2fixed (i) result (c) integer, intent(in) :: i character(200) :: c c = "" write (c, *) i c = adjustl (c) end function int2fixed pure module function int2string (i) result (s) integer, intent(in) :: i type (string_t) :: s s = trim (int2fixed (i)) end function int2string pure module function int2char (i) result (c) integer, intent(in) :: i character(len (trim (int2fixed (i)))) :: c c = int2fixed (i) end function int2char @ %def int2fixed int2string int2char @ Dito for reals. <>= public :: real2string public :: real2char public :: real2fixed <>= interface real2string module procedure real2string_list, real2string_fmt end interface interface real2char module procedure real2char_list, real2char_fmt end interface <>= pure module function real2fixed (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in), optional :: fmt character(200) :: c end function real2fixed pure module function real2fixed_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(200) :: c end function real2fixed_fmt pure module function real2string_list (x) result (s) real(default), intent(in) :: x type(string_t) :: s end function real2string_list pure module function real2string_fmt (x, fmt) result (s) real(default), intent(in) :: x character(*), intent(in) :: fmt type(string_t) :: s end function real2string_fmt pure module function real2char_list (x) result (c) real(default), intent(in) :: x character(len_trim (real2fixed (x))) :: c end function real2char_list pure module function real2char_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(len_trim (real2fixed_fmt (x, fmt))) :: c end function real2char_fmt <>= pure module function real2fixed (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in), optional :: fmt character(200) :: c c = "" write (c, *) x c = adjustl (c) end function real2fixed pure module function real2fixed_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(200) :: c c = "" write (c, fmt) x c = adjustl (c) end function real2fixed_fmt pure module function real2string_list (x) result (s) real(default), intent(in) :: x type(string_t) :: s s = trim (real2fixed (x)) end function real2string_list pure module function real2string_fmt (x, fmt) result (s) real(default), intent(in) :: x character(*), intent(in) :: fmt type(string_t) :: s s = trim (real2fixed_fmt (x, fmt)) end function real2string_fmt pure module function real2char_list (x) result (c) real(default), intent(in) :: x character(len_trim (real2fixed (x))) :: c c = real2fixed (x) end function real2char_list pure module function real2char_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(len_trim (real2fixed_fmt (x, fmt))) :: c c = real2fixed_fmt (x, fmt) end function real2char_fmt @ %def real2fixed real2string real2char @ Dito for complex values; we do not use the slightly ugly FORTRAN output form here but instead introduce our own. Ifort and Portland seem to have problems with this, therefore temporarily disable it. % <>= public :: cmplx2string public :: cmplx2char <>= pure function cmplx2string (x) result (s) complex(default), intent(in) :: x type(string_t) :: s s = real2string (real (x, default)) if (aimag (x) /= 0) s = s // " + " // real2string (aimag (x)) // " I" end function cmplx2string pure function cmplx2char (x) result (c) complex(default), intent(in) :: x character(len (char (cmplx2string (x)))) :: c c = char (cmplx2string (x)) end function cmplx2char @ %def cmplx2string cmplx2char @ \subsection{Suppression of numerical noise} <>= public :: pacify <>= interface pacify module procedure pacify_real_default module procedure pacify_complex_default end interface pacify <>= elemental module subroutine pacify_real_default (x, tolerance) real(default), intent(inout) :: x real(default), intent(in) :: tolerance end subroutine pacify_real_default elemental module subroutine pacify_complex_default (x, tolerance) complex(default), intent(inout) :: x real(default), intent(in) :: tolerance end subroutine pacify_complex_default <>= elemental module subroutine pacify_real_default (x, tolerance) real(default), intent(inout) :: x real(default), intent(in) :: tolerance if (abs (x) < tolerance) x = 0._default end subroutine pacify_real_default elemental module subroutine pacify_complex_default (x, tolerance) complex(default), intent(inout) :: x real(default), intent(in) :: tolerance if (abs (real (x)) < tolerance) & x = cmplx (0._default, aimag (x), kind=default) if (abs (aimag (x)) < tolerance) & x = cmplx (real (x), 0._default, kind=default) end subroutine pacify_complex_default @ %def pacify @ \subsection{Signal handling} Killing the program by external signals may leave the files written by it in an undefined state. This can be avoided by catching signals and deferring program termination. Instead of masking only critical sections, we choose to mask signals globally (done in the main program) and terminate the program at predefined checkpoints only. Checkpoints are after each command, within the sampling function (so the program can be terminated after each event), and after each iteration in the phase-space generation algorithm. Signal handling is done via a C interface to the [[sigaction]] system call. When a signal is raised that has been masked by the handler, the corresponding variable is set to the value of the signal. The variables are visible from the C signal handler. The signal SIGINT is for keyboard interrupt (ctrl-C), SIGTERM is for system interrupt, e.g., at shutdown. The SIGXCPU and SIGXFSZ signals may be issued by batch systems. <>= public :: wo_sigint public :: wo_sigterm public :: wo_sigxcpu public :: wo_sigxfsz <>= integer(c_int), bind(C), volatile :: wo_sigint = 0 integer(c_int), bind(C), volatile :: wo_sigterm = 0 integer(c_int), bind(C), volatile :: wo_sigxcpu = 0 integer(c_int), bind(C), volatile :: wo_sigxfsz = 0 @ %def wo_sigint wo_sigterm wo_sigxcpu wo_sigxfsz @ Here are the interfaces to the C functions. The routine [[mask_term_signals]] forces termination signals to be delayed. [[release_term_signals]] restores normal behavior. However, the program can be terminated anytime by calling [[terminate_now_if_signal]] which inspects the signals and terminates the program if requested.. <>= public :: mask_term_signals <>= module subroutine mask_term_signals () end subroutine mask_term_signals <>= module subroutine mask_term_signals () logical :: ok wo_sigint = 0 ok = wo_mask_sigint () == 0 if (.not. ok) call msg_error ("Masking SIGINT failed") wo_sigterm = 0 ok = wo_mask_sigterm () == 0 if (.not. ok) call msg_error ("Masking SIGTERM failed") wo_sigxcpu = 0 ok = wo_mask_sigxcpu () == 0 if (.not. ok) call msg_error ("Masking SIGXCPU failed") wo_sigxfsz = 0 ok = wo_mask_sigxfsz () == 0 if (.not. ok) call msg_error ("Masking SIGXFSZ failed") end subroutine mask_term_signals @ %def mask_term_signals <>= interface integer(c_int) function wo_mask_sigint () bind(C) import end function wo_mask_sigint end interface interface integer(c_int) function wo_mask_sigterm () bind(C) import end function wo_mask_sigterm end interface interface integer(c_int) function wo_mask_sigxcpu () bind(C) import end function wo_mask_sigxcpu end interface interface integer(c_int) function wo_mask_sigxfsz () bind(C) import end function wo_mask_sigxfsz end interface @ %def wo_mask_sigint wo_mask_sigterm wo_mask_sigxcpu wo_mask_sigxfsz <>= public :: release_term_signals <>= module subroutine release_term_signals () end subroutine release_term_signals <>= module subroutine release_term_signals () logical :: ok ok = wo_release_sigint () == 0 if (.not. ok) call msg_error ("Releasing SIGINT failed") ok = wo_release_sigterm () == 0 if (.not. ok) call msg_error ("Releasing SIGTERM failed") ok = wo_release_sigxcpu () == 0 if (.not. ok) call msg_error ("Releasing SIGXCPU failed") ok = wo_release_sigxfsz () == 0 if (.not. ok) call msg_error ("Releasing SIGXFSZ failed") end subroutine release_term_signals @ %def release_term_signals <>= interface integer(c_int) function wo_release_sigint () bind(C) import end function wo_release_sigint end interface interface integer(c_int) function wo_release_sigterm () bind(C) import end function wo_release_sigterm end interface interface integer(c_int) function wo_release_sigxcpu () bind(C) import end function wo_release_sigxcpu end interface interface integer(c_int) function wo_release_sigxfsz () bind(C) import end function wo_release_sigxfsz end interface @ %def wo_release_sigint wo_release_sigterm @ %def wo_release_sigxcpu wo_release_sigxfsz <>= public :: signal_is_pending <>= module function signal_is_pending () result (flag) logical :: flag end function signal_is_pending <>= module function signal_is_pending () result (flag) logical :: flag flag = & wo_sigint /= 0 .or. & wo_sigterm /= 0 .or. & wo_sigxcpu /= 0 .or. & wo_sigxfsz /= 0 end function signal_is_pending @ %def signal_is_pending <>= public :: terminate_now_if_signal <>= module subroutine terminate_now_if_signal () end subroutine terminate_now_if_signal <>= module subroutine terminate_now_if_signal () if (wo_sigint /= 0) then call msg_terminate ("Signal SIGINT (keyboard interrupt) received.", & quit_code=int (wo_sigint)) else if (wo_sigterm /= 0) then call msg_terminate ("Signal SIGTERM (termination signal) received.", & quit_code=int (wo_sigterm)) else if (wo_sigxcpu /= 0) then call msg_terminate ("Signal SIGXCPU (CPU time limit exceeded) received.", & quit_code=int (wo_sigxcpu)) else if (wo_sigxfsz /= 0) then call msg_terminate ("Signal SIGXFSZ (file size limit exceeded) received.", & quit_code=int (wo_sigxfsz)) end if end subroutine terminate_now_if_signal @ %def terminate_now_if_signal @ <>= public :: single_event <>= logical :: single_event = .false. @ <>= public :: terminate_now_if_single_event <>= module subroutine terminate_now_if_single_event () end subroutine terminate_now_if_single_event <>= module subroutine terminate_now_if_single_event () integer, save :: n_calls = 0 n_calls = n_calls + 1 if (single_event .and. n_calls > 1) then call msg_terminate ("Stopping after one event", quit_code=0) end if end subroutine terminate_now_if_single_event @ %def terminate_now_if_single_event @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Operating-system interface} For specific purposes, we need direct access to the OS (system calls). This is, of course, system dependent. The current version is valid for GNU/Linux; we expect to use a preprocessor for this module if different OSs are to be supported. The current implementation lacks error handling. <<[[os_interface.f90]]>>= <> module os_interface use, intrinsic :: iso_c_binding !NODEP! <> <> <> <> <> interface <> end interface end module os_interface @ %def os_interface @ <<[[os_interface_sub.f90]]>>= <> submodule (os_interface) os_interface_s use system_defs, only: DLERROR_LEN, ENVVAR_LEN use io_units use diagnostics use system_dependencies <> + implicit none + contains <> end submodule os_interface_s @ %def os_interface_s @ \subsection{Path variables} This is a transparent container for storing user-defined path variables. <>= public :: paths_t <>= type :: paths_t type(string_t) :: prefix type(string_t) :: exec_prefix type(string_t) :: bindir type(string_t) :: libdir type(string_t) :: includedir type(string_t) :: datarootdir type(string_t) :: localprefix type(string_t) :: libtool type(string_t) :: lhapdfdir end type paths_t @ %def paths_t <>= public :: paths_init <>= module subroutine paths_init (paths) type(paths_t), intent(out) :: paths end subroutine paths_init <>= module subroutine paths_init (paths) type(paths_t), intent(out) :: paths paths%prefix = "" paths%exec_prefix = "" paths%bindir = "" paths%libdir = "" paths%includedir = "" paths%datarootdir = "" paths%localprefix = "" paths%libtool = "" paths%lhapdfdir = "" end subroutine paths_init @ %def paths_init @ \subsection{System dependencies} We store all potentially system- and user/run-dependent data in a transparent container. This includes compiler/linker names and flags, file extensions, etc. There are actually two different possibilities for extensions of shared libraries, depending on whether the Fortran compiler or the system linker (usually the C compiler) has been used for linking. The default for the Fortran compiler on most systems is [[.so]]. <>= public :: os_data_t <>= type :: os_data_t logical :: use_libtool logical :: use_testfiles type(string_t) :: fc type(string_t) :: fcflags type(string_t) :: fcflags_pic type(string_t) :: fclibs type(string_t) :: fc_src_ext type(string_t) :: cc type(string_t) :: cflags type(string_t) :: cflags_pic type(string_t) :: cxx type(string_t) :: cxxflags type(string_t) :: cxxlibs type(string_t) :: obj_ext type(string_t) :: ld type(string_t) :: ldflags type(string_t) :: ldflags_so type(string_t) :: ldflags_static type(string_t) :: ldflags_hepmc type(string_t) :: ldflags_lcio type(string_t) :: ldflags_hoppet type(string_t) :: ldflags_looptools type(string_t) :: shrlib_ext type(string_t) :: fc_shrlib_ext type(string_t) :: pack_cmd type(string_t) :: unpack_cmd type(string_t) :: pack_ext type(string_t) :: makeflags type(string_t) :: prefix type(string_t) :: exec_prefix type(string_t) :: bindir type(string_t) :: libdir type(string_t) :: includedir type(string_t) :: datarootdir type(string_t) :: whizard_omega_binpath type(string_t) :: whizard_includes type(string_t) :: whizard_ldflags type(string_t) :: whizard_libtool type(string_t) :: whizard_modelpath type(string_t) :: whizard_modelpath_ufo type(string_t) :: whizard_models_libpath type(string_t) :: whizard_susypath type(string_t) :: whizard_gmlpath type(string_t) :: whizard_cutspath type(string_t) :: whizard_texpath type(string_t) :: whizard_sharepath type(string_t) :: whizard_testdatapath type(string_t) :: whizard_modelpath_local type(string_t) :: whizard_models_libpath_local type(string_t) :: whizard_omega_binpath_local type(string_t) :: whizard_circe2path type(string_t) :: whizard_beamsimpath type(string_t) :: whizard_mulipath type(string_t) :: pdf_builtin_datapath logical :: event_analysis = .false. logical :: event_analysis_ps = .false. logical :: event_analysis_pdf = .false. type(string_t) :: latex type(string_t) :: mpost type(string_t) :: gml type(string_t) :: dvips type(string_t) :: ps2pdf type(string_t) :: gosampath type(string_t) :: golempath type(string_t) :: formpath type(string_t) :: qgrafpath type(string_t) :: ninjapath type(string_t) :: samuraipath contains <> end type os_data_t @ %def os_data_t @ Since all are allocatable strings, explicit initialization is necessary. <>= integer, parameter, public :: ENVVAR_LEN = 1000 @ %def ENVVAR_LEN <>= procedure :: init => os_data_init <>= module subroutine os_data_init (os_data, paths) class(os_data_t), intent(out) :: os_data type(paths_t), intent(in), optional :: paths end subroutine os_data_init <>= module subroutine os_data_init (os_data, paths) class(os_data_t), intent(out) :: os_data type(paths_t), intent(in), optional :: paths character(len=ENVVAR_LEN) :: home type(string_t) :: localprefix, local_includes os_data%use_libtool = .true. inquire (file = "TESTFLAG", exist = os_data%use_testfiles) call get_environment_variable ("HOME", home) if (present(paths)) then if (paths%localprefix == "") then localprefix = trim (home) // "/.whizard" else localprefix = paths%localprefix end if else localprefix = trim (home) // "/.whizard" end if local_includes = localprefix // "/lib/whizard/mod/models" os_data%whizard_modelpath_local = localprefix // "/share/whizard/models" os_data%whizard_models_libpath_local = localprefix // "/lib/whizard/models" os_data%whizard_omega_binpath_local = localprefix // "/bin" os_data%fc = DEFAULT_FC os_data%fcflags = DEFAULT_FCFLAGS os_data%fcflags_pic = DEFAULT_FCFLAGS_PIC os_data%fclibs = FCLIBS os_data%fc_src_ext = DEFAULT_FC_SRC_EXT os_data%cc = DEFAULT_CC os_data%cflags = DEFAULT_CFLAGS os_data%cflags_pic = DEFAULT_CFLAGS_PIC os_data%cxx = DEFAULT_CXX os_data%cxxflags = DEFAULT_CXXFLAGS os_data%cxxlibs = DEFAULT_CXXLIBS os_data%obj_ext = DEFAULT_OBJ_EXT os_data%ld = DEFAULT_LD os_data%ldflags = DEFAULT_LDFLAGS os_data%ldflags_so = DEFAULT_LDFLAGS_SO os_data%ldflags_static = DEFAULT_LDFLAGS_STATIC os_data%ldflags_hepmc = DEFAULT_LDFLAGS_HEPMC os_data%ldflags_lcio = DEFAULT_LDFLAGS_LCIO os_data%ldflags_hoppet = DEFAULT_LDFLAGS_HOPPET os_data%ldflags_looptools = DEFAULT_LDFLAGS_LOOPTOOLS os_data%shrlib_ext = DEFAULT_SHRLIB_EXT os_data%fc_shrlib_ext = DEFAULT_FC_SHRLIB_EXT os_data%pack_cmd = DEFAULT_PACK_CMD os_data%unpack_cmd = DEFAULT_UNPACK_CMD os_data%pack_ext = DEFAULT_PACK_EXT os_data%makeflags = DEFAULT_MAKEFLAGS os_data%prefix = PREFIX os_data%exec_prefix = EXEC_PREFIX os_data%bindir = BINDIR os_data%libdir = LIBDIR os_data%includedir = INCLUDEDIR os_data%datarootdir = DATAROOTDIR if (present (paths)) then if (paths%prefix /= "") os_data%prefix = paths%prefix if (paths%exec_prefix /= "") os_data%exec_prefix = paths%exec_prefix if (paths%bindir /= "") os_data%bindir = paths%bindir if (paths%libdir /= "") os_data%libdir = paths%libdir if (paths%includedir /= "") os_data%includedir = paths%includedir if (paths%datarootdir /= "") os_data%datarootdir = paths%datarootdir end if if (os_data%use_testfiles) then os_data%whizard_omega_binpath = WHIZARD_TEST_OMEGA_BINPATH os_data%whizard_includes = WHIZARD_TEST_INCLUDES os_data%whizard_ldflags = WHIZARD_TEST_LDFLAGS os_data%whizard_libtool = WHIZARD_LIBTOOL_TEST os_data%whizard_modelpath = WHIZARD_TEST_MODELPATH os_data%whizard_modelpath_ufo = WHIZARD_TEST_MODELPATH_UFO os_data%whizard_models_libpath = WHIZARD_TEST_MODELS_LIBPATH os_data%whizard_susypath = WHIZARD_TEST_SUSYPATH os_data%whizard_gmlpath = WHIZARD_TEST_GMLPATH os_data%whizard_cutspath = WHIZARD_TEST_CUTSPATH os_data%whizard_texpath = WHIZARD_TEST_TEXPATH os_data%whizard_sharepath = WHIZARD_TEST_SHAREPATH os_data%whizard_testdatapath = WHIZARD_TEST_TESTDATAPATH os_data%whizard_circe2path = WHIZARD_TEST_CIRCE2PATH os_data%whizard_beamsimpath = WHIZARD_TEST_BEAMSIMPATH os_data%whizard_mulipath = WHIZARD_TEST_MULIPATH os_data%pdf_builtin_datapath = PDF_BUILTIN_TEST_DATAPATH else if (os_dir_exist (local_includes)) then os_data%whizard_includes = "-I" // local_includes // " "// & WHIZARD_INCLUDES else os_data%whizard_includes = WHIZARD_INCLUDES end if os_data%whizard_omega_binpath = WHIZARD_OMEGA_BINPATH os_data%whizard_ldflags = WHIZARD_LDFLAGS os_data%whizard_libtool = WHIZARD_LIBTOOL if(present(paths)) then if (paths%libtool /= "") os_data%whizard_libtool = paths%libtool end if os_data%whizard_modelpath = WHIZARD_MODELPATH os_data%whizard_modelpath_ufo = WHIZARD_MODELPATH_UFO os_data%whizard_models_libpath = WHIZARD_MODELS_LIBPATH os_data%whizard_susypath = WHIZARD_SUSYPATH os_data%whizard_gmlpath = WHIZARD_GMLPATH os_data%whizard_cutspath = WHIZARD_CUTSPATH os_data%whizard_texpath = WHIZARD_TEXPATH os_data%whizard_sharepath = WHIZARD_SHAREPATH os_data%whizard_testdatapath = WHIZARD_TESTDATAPATH os_data%whizard_circe2path = WHIZARD_CIRCE2PATH os_data%whizard_beamsimpath = WHIZARD_BEAMSIMPATH os_data%whizard_mulipath = WHIZARD_MULIPATH os_data%pdf_builtin_datapath = PDF_BUILTIN_DATAPATH end if os_data%event_analysis = EVENT_ANALYSIS == "yes" os_data%event_analysis_ps = EVENT_ANALYSIS_PS == "yes" os_data%event_analysis_pdf = EVENT_ANALYSIS_PDF == "yes" os_data%latex = PRG_LATEX // " " // OPT_LATEX os_data%mpost = PRG_MPOST // " " // OPT_MPOST if (os_data%use_testfiles) then os_data%gml = os_data%whizard_gmlpath // "/whizard-gml" // " " // & OPT_MPOST // " " // "--gmldir " // os_data%whizard_gmlpath else os_data%gml = os_data%bindir // "/whizard-gml" // " " // OPT_MPOST & // " " // "--gmldir " // os_data%whizard_gmlpath end if os_data%dvips = PRG_DVIPS os_data%ps2pdf = PRG_PS2PDF call os_data_expand_paths (os_data) os_data%gosampath = GOSAM_DIR os_data%golempath = GOLEM_DIR os_data%formpath = FORM_DIR os_data%qgrafpath = QGRAF_DIR os_data%ninjapath = NINJA_DIR os_data%samuraipath = SAMURAI_DIR end subroutine os_data_init @ %def os_data_init @ Replace occurences of GNU path variables (such as [[${prefix}]]) by their values. Do this for all strings that could depend on them, and do the replacement in reverse order, since the path variables may be defined in terms of each other. %% Fooling Noweb Emacs mode: $ <>= subroutine os_data_expand_paths (os_data) type(os_data_t), intent(inout) :: os_data integer, parameter :: N_VARIABLES = 6 type(string_t), dimension(N_VARIABLES) :: variable, value variable(1) = "${prefix}"; value(1) = os_data%prefix variable(2) = "${exec_prefix}"; value(2) = os_data%exec_prefix variable(3) = "${bindir}"; value(3) = os_data%bindir variable(4) = "${libdir}"; value(4) = os_data%libdir variable(5) = "${includedir}"; value(5) = os_data%includedir variable(6) = "${datarootdir}"; value(6) = os_data%datarootdir call expand_paths (os_data%whizard_omega_binpath) call expand_paths (os_data%whizard_includes) call expand_paths (os_data%whizard_ldflags) call expand_paths (os_data%whizard_libtool) call expand_paths (os_data%whizard_modelpath) call expand_paths (os_data%whizard_modelpath_ufo) call expand_paths (os_data%whizard_models_libpath) call expand_paths (os_data%whizard_susypath) call expand_paths (os_data%whizard_gmlpath) call expand_paths (os_data%whizard_cutspath) call expand_paths (os_data%whizard_texpath) call expand_paths (os_data%whizard_sharepath) call expand_paths (os_data%whizard_testdatapath) call expand_paths (os_data%whizard_circe2path) call expand_paths (os_data%whizard_beamsimpath) call expand_paths (os_data%whizard_mulipath) call expand_paths (os_data%whizard_models_libpath_local) call expand_paths (os_data%whizard_modelpath_local) call expand_paths (os_data%whizard_omega_binpath_local) call expand_paths (os_data%pdf_builtin_datapath) call expand_paths (os_data%latex) call expand_paths (os_data%mpost) call expand_paths (os_data%gml) call expand_paths (os_data%dvips) call expand_paths (os_data%ps2pdf) contains subroutine expand_paths (string) type(string_t), intent(inout) :: string integer :: i do i = N_VARIABLES, 1, -1 string = replace (string, variable(i), value(i), every=.true.) end do end subroutine expand_paths end subroutine os_data_expand_paths @ %def os_data_update_paths @ Write contents <>= procedure :: write => os_data_write <>= module subroutine os_data_write (os_data, unit) class(os_data_t), intent(in) :: os_data integer, intent(in), optional :: unit end subroutine os_data_write <>= module subroutine os_data_write (os_data, unit) class(os_data_t), intent(in) :: os_data integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "OS data:" write (u, *) "use_libtool = ", os_data%use_libtool write (u, *) "use_testfiles = ", os_data%use_testfiles write (u, *) "fc = ", char (os_data%fc) write (u, *) "fcflags = ", char (os_data%fcflags) write (u, *) "fcflags_pic = ", char (os_data%fcflags_pic) write (u, *) "fclibs = ", char (os_data%fclibs) write (u, *) "fc_src_ext = ", char (os_data%fc_src_ext) write (u, *) "cc = ", char (os_data%cc) write (u, *) "cflags = ", char (os_data%cflags) write (u, *) "cflags_pic = ", char (os_data%cflags_pic) write (u, *) "cxx = ", char (os_data%cxx) write (u, *) "cxxflags = ", char (os_data%cxxflags) write (u, *) "cxxlibs = ", char (os_data%cxxlibs) write (u, *) "obj_ext = ", char (os_data%obj_ext) write (u, *) "ld = ", char (os_data%ld) write (u, *) "ldflags = ", char (os_data%ldflags) write (u, *) "ldflags_so = ", char (os_data%ldflags_so) write (u, *) "ldflags_static = ", char (os_data%ldflags_static) write (u, *) "ldflags_hepmc = ", char (os_data%ldflags_hepmc) write (u, *) "ldflags_lcio = ", char (os_data%ldflags_lcio) write (u, *) "ldflags_hoppet = ", char (os_data%ldflags_hoppet) write (u, *) "ldflags_looptools = ", char (os_data%ldflags_looptools) write (u, *) "shrlib_ext = ", char (os_data%shrlib_ext) write (u, *) "fc_shrlib_ext = ", char (os_data%fc_shrlib_ext) write (u, *) "makeflags = ", char (os_data%makeflags) write (u, *) "prefix = ", char (os_data%prefix) write (u, *) "exec_prefix = ", char (os_data%exec_prefix) write (u, *) "bindir = ", char (os_data%bindir) write (u, *) "libdir = ", char (os_data%libdir) write (u, *) "includedir = ", char (os_data%includedir) write (u, *) "datarootdir = ", char (os_data%datarootdir) write (u, *) "whizard_omega_binpath = ", & char (os_data%whizard_omega_binpath) write (u, *) "whizard_includes = ", char (os_data%whizard_includes) write (u, *) "whizard_ldflags = ", char (os_data%whizard_ldflags) write (u, *) "whizard_libtool = ", char (os_data%whizard_libtool) write (u, *) "whizard_modelpath = ", & char (os_data%whizard_modelpath) write (u, *) "whizard_modelpath_ufo = ", & char (os_data%whizard_modelpath_ufo) write (u, *) "whizard_models_libpath = ", & char (os_data%whizard_models_libpath) write (u, *) "whizard_susypath = ", char (os_data%whizard_susypath) write (u, *) "whizard_gmlpath = ", char (os_data%whizard_gmlpath) write (u, *) "whizard_cutspath = ", char (os_data%whizard_cutspath) write (u, *) "whizard_texpath = ", char (os_data%whizard_texpath) write (u, *) "whizard_circe2path = ", char (os_data%whizard_circe2path) write (u, *) "whizard_beamsimpath = ", char (os_data%whizard_beamsimpath) write (u, *) "whizard_mulipath = ", char (os_data%whizard_mulipath) write (u, *) "whizard_sharepath = ", & char (os_data%whizard_sharepath) write (u, *) "whizard_testdatapath = ", & char (os_data%whizard_testdatapath) write (u, *) "whizard_modelpath_local = ", & char (os_data%whizard_modelpath_local) write (u, *) "whizard_models_libpath_local = ", & char (os_data%whizard_models_libpath_local) write (u, *) "whizard_omega_binpath_local = ", & char (os_data%whizard_omega_binpath_local) write (u, *) "event_analysis = ", os_data%event_analysis write (u, *) "event_analysis_ps = ", os_data%event_analysis_ps write (u, *) "event_analysis_pdf = ", os_data%event_analysis_pdf write (u, *) "latex = ", char (os_data%latex) write (u, *) "mpost = ", char (os_data%mpost) write (u, *) "gml = ", char (os_data%gml) write (u, *) "dvips = ", char (os_data%dvips) write (u, *) "ps2pdf = ", char (os_data%ps2pdf) if (os_data%gosampath /= "") then write (u, *) "gosam = ", char (os_data%gosampath) write (u, *) "golem = ", char (os_data%golempath) write (u, *) "form = ", char (os_data%formpath) write (u, *) "qgraf = ", char (os_data%qgrafpath) write (u, *) "ninja = ", char (os_data%ninjapath) write (u, *) "samurai = ", char (os_data%samuraipath) end if end subroutine os_data_write @ %def os_data_write @ <>= procedure :: build_latex_file => os_data_build_latex_file <>= module subroutine os_data_build_latex_file (os_data, filename, stat_out) class(os_data_t), intent(in) :: os_data type(string_t), intent(in) :: filename integer, intent(out), optional :: stat_out end subroutine os_data_build_latex_file <>= module subroutine os_data_build_latex_file (os_data, filename, stat_out) class(os_data_t), intent(in) :: os_data type(string_t), intent(in) :: filename integer, intent(out), optional :: stat_out type(string_t) :: setenv_tex, pipe, pipe_dvi integer :: unit_dev, status status = -1 if (os_data%event_analysis_ps) then !!! Check if our OS has a /dev/null unit_dev = free_unit () open (file = "/dev/null", unit = unit_dev, & action = "write", iostat = status) close (unit_dev) if (status /= 0) then pipe = "" pipe_dvi = "" else pipe = " > /dev/null" pipe_dvi = " 2>/dev/null 1>/dev/null" end if if (os_data%whizard_texpath /= "") then setenv_tex = "TEXINPUTS=" // & os_data%whizard_texpath // ":$TEXINPUTS " else setenv_tex = "" end if call os_system_call (setenv_tex // & os_data%latex // " " // filename // ".tex " // pipe, & verbose = .true., status = status) call os_system_call (os_data%dvips // " -o " // filename // & ".ps " // filename // ".dvi" // pipe_dvi, verbose = .true., & status = status) call os_system_call (os_data%ps2pdf // " " // filename // ".ps", & verbose = .true., status = status) end if if (present (stat_out)) stat_out = status end subroutine os_data_build_latex_file @ %def os_data_build_latex_file @ \subsection{Dynamic linking} We define a type that holds the filehandle for a dynamically linked library (shared object), together with functions to open and close the library, and to access functions in this library. <>= public :: dlaccess_t <>= type :: dlaccess_t private type(string_t) :: filename type(c_ptr) :: handle = c_null_ptr logical :: is_open = .false. logical :: has_error = .false. type(string_t) :: error contains <> end type dlaccess_t @ %def dlaccess_t @ Output. This is called by the output routine for the process library. <>= procedure :: write => dlaccess_write <>= module subroutine dlaccess_write (object, unit) class(dlaccess_t), intent(in) :: object integer, intent(in) :: unit end subroutine dlaccess_write <>= module subroutine dlaccess_write (object, unit) class(dlaccess_t), intent(in) :: object integer, intent(in) :: unit write (unit, "(1x,A)") "DL access info:" write (unit, "(3x,A,L1)") "is open = ", object%is_open if (object%has_error) then write (unit, "(3x,A,A,A)") "error = '", char (object%error), "'" else write (unit, "(3x,A)") "error = [none]" end if end subroutine dlaccess_write @ %def dlaccess_write @ The interface to the library functions: <>= interface function dlopen (filename, flag) result (handle) bind(C) import character(c_char), dimension(*) :: filename integer(c_int), value :: flag type(c_ptr) :: handle end function dlopen end interface interface function dlclose (handle) result (status) bind(C) import type(c_ptr), value :: handle integer(c_int) :: status end function dlclose end interface interface function dlerror () result (str) bind(C) import type(c_ptr) :: str end function dlerror end interface interface function dlsym (handle, symbol) result (fptr) bind(C) import type(c_ptr), value :: handle character(c_char), dimension(*) :: symbol type(c_funptr) :: fptr end function dlsym end interface @ %def dlopen dlclose dlsym @ This reads an error string and transforms it into a [[string_t]] object, if an error has occured. If not, set the error flag to false and return an empty string. <>= integer, parameter, public :: DLERROR_LEN = 160 <>= subroutine read_dlerror (has_error, error) logical, intent(out) :: has_error type(string_t), intent(out) :: error type(c_ptr) :: err_cptr character(len=DLERROR_LEN, kind=c_char), pointer :: err_fptr integer :: str_end err_cptr = dlerror () if (c_associated (err_cptr)) then call c_f_pointer (err_cptr, err_fptr) has_error = .true. str_end = scan (err_fptr, c_null_char) if (str_end > 0) then error = err_fptr(1:str_end-1) else error = err_fptr end if else has_error = .false. error = "" end if end subroutine read_dlerror @ %def read_dlerror @ This is the Fortran API. Init/final open and close the file, i.e., load and unload the library. Note that a library can be opened more than once, and that for an ultimate close as many [[dlclose]] calls as [[dlopen]] calls are necessary. However, we assume that it is opened and closed only once. <>= public :: dlaccess_init public :: dlaccess_final <>= procedure :: init => dlaccess_init procedure :: final => dlaccess_final <>= module subroutine dlaccess_init (dlaccess, prefix, libname, os_data) class(dlaccess_t), intent(out) :: dlaccess type(string_t), intent(in) :: prefix, libname type(os_data_t), intent(in), optional :: os_data end subroutine dlaccess_init module subroutine dlaccess_final (dlaccess) class(dlaccess_t), intent(inout) :: dlaccess end subroutine dlaccess_final <>= module subroutine dlaccess_init (dlaccess, prefix, libname, os_data) class(dlaccess_t), intent(out) :: dlaccess type(string_t), intent(in) :: prefix, libname type(os_data_t), intent(in), optional :: os_data type(string_t) :: filename logical :: exist dlaccess%filename = libname filename = prefix // "/" // libname inquire (file=char(filename), exist=exist) if (.not. exist) then filename = prefix // "/.libs/" // libname inquire (file=char(filename), exist=exist) if (.not. exist) then dlaccess%has_error = .true. dlaccess%error = "Library '" // filename // "' not found" return end if end if dlaccess%handle = dlopen (char (filename) // c_null_char, ior ( & RTLD_LAZY, RTLD_LOCAL)) dlaccess%is_open = c_associated (dlaccess%handle) call read_dlerror (dlaccess%has_error, dlaccess%error) end subroutine dlaccess_init module subroutine dlaccess_final (dlaccess) class(dlaccess_t), intent(inout) :: dlaccess integer(c_int) :: status if (dlaccess%is_open) then status = dlclose (dlaccess%handle) dlaccess%is_open = .false. call read_dlerror (dlaccess%has_error, dlaccess%error) end if end subroutine dlaccess_final @ %def dlaccess_init dlaccess_final @ Return true if an error has occured. <>= public :: dlaccess_has_error <>= module function dlaccess_has_error (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess end function dlaccess_has_error <>= module function dlaccess_has_error (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess flag = dlaccess%has_error end function dlaccess_has_error @ %def dlaccess_has_error @ Return the error string currently stored in the [[dlaccess]] object. <>= public :: dlaccess_get_error <>= module function dlaccess_get_error (dlaccess) result (error) type(string_t) :: error type(dlaccess_t), intent(in) :: dlaccess end function dlaccess_get_error <>= module function dlaccess_get_error (dlaccess) result (error) type(string_t) :: error type(dlaccess_t), intent(in) :: dlaccess error = dlaccess%error end function dlaccess_get_error @ %def dlaccess_get_error @ The symbol handler returns the C address of the function with the given string name. (It is a good idea to use [[bind(C)]] for all functions accessed by this, such that the name string is well-defined.) Call [[c_f_procpointer]] to cast this into a Fortran procedure pointer with an appropriate interface. <>= public :: dlaccess_get_c_funptr <>= module function dlaccess_get_c_funptr (dlaccess, fname) result (fptr) type(c_funptr) :: fptr type(dlaccess_t), intent(inout) :: dlaccess type(string_t), intent(in) :: fname end function dlaccess_get_c_funptr <>= module function dlaccess_get_c_funptr (dlaccess, fname) result (fptr) type(c_funptr) :: fptr type(dlaccess_t), intent(inout) :: dlaccess type(string_t), intent(in) :: fname fptr = dlsym (dlaccess%handle, char (fname) // c_null_char) call read_dlerror (dlaccess%has_error, dlaccess%error) end function dlaccess_get_c_funptr @ %def dlaccess_get_c_funptr @ \subsection{Predicates} Return true if the library is loaded. In particular, this is false if loading was unsuccessful. <>= public :: dlaccess_is_open <>= module function dlaccess_is_open (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess end function dlaccess_is_open <>= module function dlaccess_is_open (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess flag = dlaccess%is_open end function dlaccess_is_open @ %def dlaccess_is_open @ \subsection{Shell access} This is the standard system call for executing a shell command, such as invoking a compiler. In F2008 there will be the equivalent built-in command [[execute_command_line]]. <>= public :: os_system_call <>= module subroutine os_system_call (command_string, status, verbose) type(string_t), intent(in) :: command_string integer, intent(out), optional :: status logical, intent(in), optional :: verbose end subroutine os_system_call <>= module subroutine os_system_call (command_string, status, verbose) type(string_t), intent(in) :: command_string integer, intent(out), optional :: status logical, intent(in), optional :: verbose logical :: verb integer :: stat verb = .false.; if (present (verbose)) verb = verbose if (verb) & call msg_message ("command: " // char (command_string)) stat = system (char (command_string) // c_null_char) if (present (status)) then status = stat else if (stat /= 0) then if (.not. verb) & call msg_message ("command: " // char (command_string)) write (msg_buffer, "(A,I0)") "Return code = ", stat call msg_message () call msg_fatal ("System command returned with nonzero status code") end if end subroutine os_system_call @ %def os_system_call <>= interface function system (command) result (status) bind(C) import integer(c_int) :: status character(c_char), dimension(*) :: command end function system end interface @ %def system @ \subsection{Querying for a directory} This queries for the existence of a directory. There is no standard way to achieve this in FORTRAN, and if we were to call into [[libc]], we would need access to C macros for evaluating the result, so we resort to calling [[test]] as a system call. <>= public :: os_dir_exist <>= module function os_dir_exist (name) result (res) type(string_t), intent(in) :: name logical :: res end function os_dir_exist <>= module function os_dir_exist (name) result (res) type(string_t), intent(in) :: name logical :: res integer :: status call os_system_call ('test -d "' // name // '"', status=status) res = status == 0 end function os_dir_exist @ %def os_dir_exist @ <>= public :: os_file_exist <>= module function os_file_exist (name) result (exist) type(string_t), intent(in) :: name logical :: exist end function os_file_exist <>= module function os_file_exist (name) result (exist) type(string_t), intent(in) :: name logical :: exist inquire (file = char (name), exist=exist) end function os_file_exist @ %def os_file_exist @ \subsection{Pack/unpack} The argument to [[pack]] may be a file or a directory. The name of the packed file will get the [[pack_ext]] extension appended. The argument to [[unpack]] must be a file, with the extension already included in the file name. <>= public :: os_pack_file public :: os_unpack_file <>= module subroutine os_pack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_pack_file module subroutine os_unpack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_unpack_file <>= module subroutine os_pack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string command_string = os_data%pack_cmd // " " & // file // os_data%pack_ext // " " // file call os_system_call (command_string, status) end subroutine os_pack_file module subroutine os_unpack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string command_string = os_data%unpack_cmd // " " // file call os_system_call (command_string, status) end subroutine os_unpack_file @ %def os_pack_file @ %def os_unpack_file @ \subsection{Fortran compiler and linker} Compile a single module for use in a shared library, but without linking. <>= public :: os_compile_shared <>= module subroutine os_compile_shared (src, os_data, status) type(string_t), intent(in) :: src type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_compile_shared <>= module subroutine os_compile_shared (src, os_data, status) type(string_t), intent(in) :: src type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=compile " // & os_data%fc // " " // & "-c " // & os_data%whizard_includes // " " // & os_data%fcflags // " " // & "'" // src // os_data%fc_src_ext // "'" else command_string = & os_data%fc // " " // & "-c " // & os_data%fcflags_pic // " " // & os_data%whizard_includes // " " // & os_data%fcflags // " " // & "'" // src // os_data%fc_src_ext // "'" end if call os_system_call (command_string, status) end subroutine os_compile_shared @ %def os_compile_shared @ Link an array of object files to build a shared object library. In the libtool case, we have to specify a [[-rpath]], otherwise only a static library can be built. However, since the library is never installed, this rpath is irrelevant. <>= public :: os_link_shared <>= module subroutine os_link_shared (objlist, lib, os_data, status) type(string_t), intent(in) :: objlist, lib type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_link_shared <>= module subroutine os_link_shared (objlist, lib, os_data, status) type(string_t), intent(in) :: objlist, lib type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=link " // & os_data%fc // " " // & "-module " // & "-rpath /usr/local/lib" // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & "-o '" // lib // ".la' " // & objlist else command_string = & os_data%ld // " " // & os_data%ldflags_so // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & "-o '" // lib // "." // os_data%fc_shrlib_ext // "' " // & objlist end if call os_system_call (command_string, status) end subroutine os_link_shared @ %def os_link_shared @ Link an array of object files / libraries to build a static executable. <>= public :: os_link_static <>= module subroutine os_link_static (objlist, exec_name, os_data, status) type(string_t), intent(in) :: objlist, exec_name type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status end subroutine os_link_static <>= module subroutine os_link_static (objlist, exec_name, os_data, status) type(string_t), intent(in) :: objlist, exec_name type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=link " // & os_data%fc // " " // & "-static " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & os_data%ldflags_static // " " // & "-o '" // exec_name // "' " // & objlist // " " // & os_data%ldflags_hepmc // " " // & os_data%ldflags_lcio // " " // & os_data%ldflags_hoppet // " " // & os_data%ldflags_looptools else command_string = & os_data%ld // " " // & os_data%ldflags_so // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & os_data%ldflags_static // " " // & "-o '" // exec_name // "' " // & objlist // " " // & os_data%ldflags_hepmc // " " // & os_data%ldflags_lcio // " " // & os_data%ldflags_hoppet // " " // & os_data%ldflags_looptools end if call os_system_call (command_string, status) end subroutine os_link_static @ %def os_link_static @ Determine the name of the shared library to link. If libtool is used, this is encoded in the [[.la]] file which resides in place of the library itself. <>= public :: os_get_dlname <>= module function os_get_dlname (lib, os_data, ignore, silent) result (dlname) type(string_t) :: dlname type(string_t), intent(in) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: ignore, silent end function os_get_dlname <>= module function os_get_dlname (lib, os_data, ignore, silent) result (dlname) type(string_t) :: dlname type(string_t), intent(in) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: ignore, silent type(string_t) :: filename type(string_t) :: buffer logical :: exist, required, quiet integer :: u u = free_unit () if (present (ignore)) then required = .not. ignore else required = .true. end if if (present (silent)) then quiet = silent else quiet = .false. end if if (os_data%use_libtool) then filename = lib // ".la" inquire (file=char(filename), exist=exist) if (exist) then open (unit=u, file=char(filename), action="read", status="old") SCAN_LTFILE: do call get (u, buffer) if (extract (buffer, 1, 7) == "dlname=") then dlname = extract (buffer, 9) dlname = remove (dlname, len (dlname)) exit SCAN_LTFILE end if end do SCAN_LTFILE close (u) else if (required) then if (.not. quiet) call msg_fatal (" Library '" // char (lib) & // "': libtool archive not found") dlname = "" else if (.not. quiet) call msg_message ("[No compiled library '" & // char (lib) // "']") dlname = "" end if else dlname = lib // "." // os_data%fc_shrlib_ext inquire (file=char(dlname), exist=exist) if (.not. exist) then if (required) then if (.not. quiet) call msg_fatal (" Library '" // char (lib) & // "' not found") else if (.not. quiet) call msg_message & ("[No compiled process library '" // char (lib) // "']") dlname = "" end if end if end if end function os_get_dlname @ %def os_get_dlname @ \subsection{Controlling OpenMP} OpenMP is handled automatically by the library for the most part. Here is a convenience routine for setting the number of threads, with some diagnostics. <>= public :: openmp_set_num_threads_verbose <>= module subroutine openmp_set_num_threads_verbose (num_threads, openmp_logging) integer, intent(in) :: num_threads logical, intent(in), optional :: openmp_logging end subroutine openmp_set_num_threads_verbose <>= module subroutine openmp_set_num_threads_verbose (num_threads, openmp_logging) integer, intent(in) :: num_threads integer :: n_threads logical, intent(in), optional :: openmp_logging logical :: logging if (present (openmp_logging)) then logging = openmp_logging else logging = .true. end if n_threads = num_threads if (openmp_is_active ()) then if (num_threads == 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", num_threads, & " thread" call msg_message end if n_threads = num_threads else if (num_threads > 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", num_threads, & " threads" call msg_message end if n_threads = num_threads else if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: " & // "Illegal value of openmp_num_threads (", num_threads, & ") ignored" call msg_error end if n_threads = openmp_get_default_max_threads () if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", & n_threads, " threads" call msg_message end if end if if (n_threads > openmp_get_default_max_threads ()) then if (logging) then write (msg_buffer, "(A,I0)") "OpenMP: " & // "Number of threads is greater than library default of ", & openmp_get_default_max_threads () call msg_warning end if end if call openmp_set_num_threads (n_threads) else if (num_threads /= 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "openmp_num_threads set to ", & num_threads, ", but OpenMP is not active: ignored" call msg_warning end if end if end subroutine openmp_set_num_threads_verbose @ %def openmp_set_num_threads_verbose @ \subsection{Controlling MPI} The overall MPI handling has to be defined in a context specific way, but we can simplify things like logging or receiving [[n_size]] or [[rank]]. <>= public :: mpi_set_logging <>= module subroutine mpi_set_logging (mpi_logging) logical, intent(in) :: mpi_logging end subroutine mpi_set_logging <>= module subroutine mpi_set_logging (mpi_logging) logical, intent(in) :: mpi_logging integer :: n_size, rank call mpi_get_comm_id (n_size, rank) if (mpi_logging .and. n_size > 1) then write (msg_buffer, "(A,I0,A)") "MPI: Using ", n_size, " processes." call msg_message () if (rank == 0) then call msg_message ("MPI: master worker") else write (msg_buffer, "(A,I0)") "MPI: slave worker #", rank call msg_message () end if end if end subroutine mpi_set_logging @ %def mpi_set_logging @ Receive communicator size and rank inside communicator. The subroutine is a stub, if not compiled with [[MPI]]. <>= public :: mpi_get_comm_id <>= module subroutine mpi_get_comm_id (n_size, rank) integer, intent(out) :: n_size integer, intent(out) :: rank end subroutine mpi_get_comm_id <>= module subroutine mpi_get_comm_id (n_size, rank) integer, intent(out) :: n_size integer, intent(out) :: rank n_size = 1 rank = 0 <> end subroutine mpi_get_comm_id @ %def mpi_get_comm_id <>= @ <>= call MPI_Comm_size (MPI_COMM_WORLD, n_size) call MPI_Comm_rank (MPI_COMM_WORLD, rank) @ <>= public :: mpi_is_comm_master <>= module function mpi_is_comm_master () result (flag) logical :: flag end function mpi_is_comm_master <>= module function mpi_is_comm_master () result (flag) integer :: n_size, rank logical :: flag call mpi_get_comm_id (n_size, rank) flag = (rank == 0) end function mpi_is_comm_master @ %def mpi_is_comm_master @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[os_interface_ut.f90]]>>= <> module os_interface_ut use unit_tests use os_interface_uti <> <> contains <> end module os_interface_ut @ %def os_interface_ut @ <<[[os_interface_uti.f90]]>>= <> module os_interface_uti use, intrinsic :: iso_c_binding !NODEP! <> use io_units use os_interface <> <> contains <> end module os_interface_uti @ %def os_interface_ut @ API: driver for the unit tests below. <>= public :: os_interface_test <>= subroutine os_interface_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine os_interface_test @ %def os_interface_test @ Write a Fortran source file, compile it to a shared library, load it, and execute the contained function. <>= call test (os_interface_1, "os_interface_1", & "check OS interface routines", & u, results) <>= public :: os_interface_1 <>= subroutine os_interface_1 (u) integer, intent(in) :: u type(dlaccess_t) :: dlaccess type(string_t) :: fname, libname, ext type(os_data_t) :: os_data type(string_t) :: filename_src, filename_obj abstract interface function so_test_proc (i) result (j) bind(C) import c_int integer(c_int), intent(in) :: i integer(c_int) :: j end function so_test_proc end interface procedure(so_test_proc), pointer :: so_test => null () type(c_funptr) :: c_fptr integer :: unit integer(c_int) :: i call os_data%init () fname = "so_test" filename_src = fname // os_data%fc_src_ext if (os_data%use_libtool) then ext = ".lo" else ext = os_data%obj_ext end if filename_obj = fname // ext libname = fname // '.' // os_data%fc_shrlib_ext write (u, "(A)") "* Test output: OS interface" write (u, "(A)") "* Purpose: check os_interface routines" write (u, "(A)") write (u, "(A)") "* write source file 'so_test.f90'" write (u, "(A)") unit = free_unit () open (unit=unit, file=char(filename_src), action="write") write (unit, "(A)") "function so_test (i) result (j) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " integer(c_int) :: j" write (unit, "(A)") " j = 2 * i" write (unit, "(A)") "end function so_test" close (unit) write (u, "(A)") "* compile and link as 'so_test.so/dylib'" write (u, "(A)") call os_compile_shared (fname, os_data) call os_link_shared (filename_obj, fname, os_data) write (u, "(A)") "* load library 'so_test.so/dylib'" write (u, "(A)") call dlaccess_init (dlaccess, var_str ("."), libname, os_data) if (dlaccess_is_open (dlaccess)) then write (u, "(A)") " success" else write (u, "(A)") " failure" end if write (u, "(A)") "* load symbol 'so_test'" write (u, "(A)") c_fptr = dlaccess_get_c_funptr (dlaccess, fname) if (c_associated (c_fptr)) then write (u, "(A)") " success" else write (u, "(A)") " failure" end if call c_f_procpointer (c_fptr, so_test) write (u, "(A)") "* Execute function from 'so_test.so/dylib'" i = 7 write (u, "(A,1x,I1)") " input = ", i write (u, "(A,1x,I1)") " result = ", so_test(i) if (so_test(i) / i .ne. 2) then write (u, "(A)") "* Compiling and linking ISO C functions failed." else write (u, "(A)") "* Successful." end if write (u, "(A)") write (u, "(A)") "* Cleanup" call dlaccess_final (dlaccess) end subroutine os_interface_1 @ %def os_interface_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Interface for formatted I/O} For access to formatted printing (possibly input), we interface the C [[printf]] family of functions. There are two important issues here: \begin{enumerate} \item [[printf]] takes an arbitrary number of arguments, relying on the C stack. This is not interoperable. We interface it with C wrappers that output a single integer, real or string and restrict the allowed formats accordingly. \item Restricting format strings is essential also for preventing format string attacks. Allowing arbitrary format string would create a real security hole in a Fortran program. \item The string returned by [[sprintf]] must be allocated to the right size. \end{enumerate} <<[[formats.f90]]>>= <> module formats use, intrinsic :: iso_c_binding <> <> <> <> <> <> <> interface <> end interface end module formats @ %def formats @ <<[[formats_sub.f90]]>>= <> submodule (formats) formats_s use io_units use diagnostics + implicit none + contains <> end submodule formats_s @ %def formats_s @ \subsection{Parsing a C format string} The C format string contains characters and format conversion specifications. The latter are initiated by a [[%]] sign. If the next letter is also a [[%]], a percent sign is printed and no conversion is done. Otherwise, a conversion is done and applied to the next argument in the argument list. First comes an optional flag ([[#]], [[0]], [[-]], [[+]], or space), an optional field width (decimal digits starting not with zero), an optional precision (period, then another decimal digit string), a length modifier (irrelevant for us, therefore not supported), and a conversion specifier: [[d]] or [[i]] for integer; [[e]], [[f]], [[g]] (also upper case) for double-precision real, [[s]] for a string. We explicitly exclude all other conversion specifiers, and we check the specifiers against the actual arguments. \subsubsection{A type for passing arguments} This is a polymorphic type that can hold integer, real (double), and string arguments. <>= integer, parameter, public :: ARGTYPE_NONE = 0 integer, parameter, public :: ARGTYPE_LOG = 1 integer, parameter, public :: ARGTYPE_INT = 2 integer, parameter, public :: ARGTYPE_REAL = 3 integer, parameter, public :: ARGTYPE_STR = 4 @ %def ARGTYPE_NONE ARGTYPE_LOG ARGTYPE_INT ARGTYPE_REAL ARGTYPE_STRING @ The integer and real entries are actually scalars, but we avoid relying on the allocatable-scalar feature and make them one-entry arrays. The character entry is a real array which is a copy of the string. Logical values are mapped to strings (true or false), so this type parameter value is mostly unused. <>= public :: sprintf_arg_t <>= type :: sprintf_arg_t private integer :: type = ARGTYPE_NONE integer(c_int), dimension(:), allocatable :: ival real(c_double), dimension(:), allocatable :: rval character(c_char), dimension(:), allocatable :: sval end type sprintf_arg_t @ %def sprintf_arg_t <>= public :: sprintf_arg_init <>= interface sprintf_arg_init module procedure sprintf_arg_init_log module procedure sprintf_arg_init_int module procedure sprintf_arg_init_real module procedure sprintf_arg_init_str end interface <>= module subroutine sprintf_arg_init_log (arg, lval) type(sprintf_arg_t), intent(out) :: arg logical, intent(in) :: lval end subroutine sprintf_arg_init_log module subroutine sprintf_arg_init_int (arg, ival) type(sprintf_arg_t), intent(out) :: arg integer, intent(in) :: ival end subroutine sprintf_arg_init_int module subroutine sprintf_arg_init_real (arg, rval) type(sprintf_arg_t), intent(out) :: arg real(default), intent(in) :: rval end subroutine sprintf_arg_init_real module subroutine sprintf_arg_init_str (arg, sval) type(sprintf_arg_t), intent(out) :: arg type(string_t), intent(in) :: sval end subroutine sprintf_arg_init_str <>= module subroutine sprintf_arg_init_log (arg, lval) type(sprintf_arg_t), intent(out) :: arg logical, intent(in) :: lval arg%type = ARGTYPE_STR if (lval) then allocate (arg%sval (5)) arg%sval = ['t', 'r', 'u', 'e', c_null_char] else allocate (arg%sval (6)) arg%sval = ['f', 'a', 'l', 's', 'e', c_null_char] end if end subroutine sprintf_arg_init_log module subroutine sprintf_arg_init_int (arg, ival) type(sprintf_arg_t), intent(out) :: arg integer, intent(in) :: ival arg%type = ARGTYPE_INT allocate (arg%ival (1)) arg%ival = ival end subroutine sprintf_arg_init_int module subroutine sprintf_arg_init_real (arg, rval) type(sprintf_arg_t), intent(out) :: arg real(default), intent(in) :: rval arg%type = ARGTYPE_REAL allocate (arg%rval (1)) arg%rval = rval end subroutine sprintf_arg_init_real module subroutine sprintf_arg_init_str (arg, sval) type(sprintf_arg_t), intent(out) :: arg type(string_t), intent(in) :: sval integer :: i arg%type = ARGTYPE_STR allocate (arg%sval (len (sval) + 1)) do i = 1, len (sval) arg%sval(i) = extract (sval, i, i) end do arg%sval(len (sval) + 1) = c_null_char end subroutine sprintf_arg_init_str @ %def sprintf_arg_init <>= subroutine sprintf_arg_write (arg, unit) type(sprintf_arg_t), intent(in) :: arg integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) select case (arg%type) case (ARGTYPE_NONE) write (u, *) "[none]" case (ARGTYPE_INT) write (u, "(1x,A,1x)", advance = "no") "[int]" write (u, *) arg%ival case (ARGTYPE_REAL) write (u, "(1x,A,1x)", advance = "no") "[real]" write (u, *) arg%rval case (ARGTYPE_STR) write (u, "(1x,A,1x,A)", advance = "no") "[string]", '"' write (u, *) arg%rval, '"' end select end subroutine sprintf_arg_write @ %def sprintf_arg_write @ Return an upper bound for the length of the printed version; in case of strings the result is exact. <>= elemental function sprintf_arg_get_length (arg) result (length) integer :: length type(sprintf_arg_t), intent(in) :: arg select case (arg%type) case (ARGTYPE_INT) length = log10 (real (huge (arg%ival(1)))) + 2 case (ARGTYPE_REAL) length = log10 (real (radix (arg%rval(1))) ** digits (arg%rval(1))) + 8 case (ARGTYPE_STR) length = size (arg%sval) case default length = 0 end select end function sprintf_arg_get_length @ %def sprintf_arg_get_length <>= subroutine sprintf_arg_apply_sprintf (arg, fmt, result, actual_length) type(sprintf_arg_t), intent(in) :: arg character(c_char), dimension(:), intent(in) :: fmt character(c_char), dimension(:), intent(inout) :: result integer, intent(out) :: actual_length integer(c_int) :: ival real(c_double) :: rval select case (arg%type) case (ARGTYPE_NONE) actual_length = sprintf_none (result, fmt) case (ARGTYPE_INT) ival = arg%ival(1) actual_length = sprintf_int (result, fmt, ival) case (ARGTYPE_REAL) rval = arg%rval(1) actual_length = sprintf_double (result, fmt, rval) case (ARGTYPE_STR) actual_length = sprintf_str (result, fmt, arg%sval) case default call msg_bug ("sprintf_arg_apply_sprintf called with illegal type") end select if (actual_length < 0) then write (msg_buffer, *) "Format: '", fmt, "'" call msg_message () write (msg_buffer, *) "Output: '", result, "'" call msg_message () call msg_error ("I/O error in sprintf call") actual_length = 0 end if end subroutine sprintf_arg_apply_sprintf @ %def sprintf_arg_apply_sprintf @ \subsubsection{Container type for the output} There is a procedure which chops the format string into pieces that contain at most one conversion specifier. Pairing this with a [[sprintf_arg]] object, we get the actual input to the [[sprintf]] interface. The type below holds this input and can allocate the output string. <>= type :: sprintf_interface_t private character(c_char), dimension(:), allocatable :: input_fmt type(sprintf_arg_t) :: arg character(c_char), dimension(:), allocatable :: output_str integer :: output_str_len = 0 end type sprintf_interface_t @ %def sprintf_fmt_t <>= subroutine sprintf_interface_init (intf, fmt, arg) type(sprintf_interface_t), intent(out) :: intf type(string_t), intent(in) :: fmt type(sprintf_arg_t), intent(in) :: arg integer :: fmt_len, i fmt_len = len (fmt) allocate (intf%input_fmt (fmt_len + 1)) do i = 1, fmt_len intf%input_fmt(i) = extract (fmt, i, i) end do intf%input_fmt(fmt_len+1) = c_null_char intf%arg = arg allocate (intf%output_str (len (fmt) + sprintf_arg_get_length (arg) + 1)) end subroutine sprintf_interface_init @ %def sprintf_interface_init <>= subroutine sprintf_interface_write (intf, unit) type(sprintf_interface_t), intent(in) :: intf integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, *) "Format string = ", '"', intf%input_fmt, '"' write (u, "(1x,A,1x)", advance = "no") "Argument = " call sprintf_arg_write (intf%arg, unit) if (intf%output_str_len > 0) then write (u, *) "Result string = ", & '"', intf%output_str (1:intf%output_str_len), '"' end if end subroutine sprintf_interface_write @ %def sprintf_interface_write @ Return the output string: <>= function sprintf_interface_get_result (intf) result (string) type(string_t) :: string type(sprintf_interface_t), intent(in) :: intf character(kind = c_char, len = max (intf%output_str_len, 0)) :: buffer integer :: i if (intf%output_str_len > 0) then do i = 1, intf%output_str_len buffer(i:i) = intf%output_str(i) end do string = buffer(1:intf%output_str_len) else string = "" end if end function sprintf_interface_get_result @ %def sprintf_interface_get_result <>= subroutine sprintf_interface_apply_sprintf (intf) type(sprintf_interface_t), intent(inout) :: intf call sprintf_arg_apply_sprintf & (intf%arg, intf%input_fmt, intf%output_str, intf%output_str_len) end subroutine sprintf_interface_apply_sprintf @ %def sprintf_interface_apply_sprintf @ Import the interfaces defined in the previous section: <>= <> @ \subsubsection{Scan the format string} Chop it into pieces that contain one conversion specifier each. The zero-th piece contains the part before the first specifier. Check the specifiers and allow only the subset that we support. Also check for an exact match between conversion specifiers and input arguments. The result is an allocated array of [[sprintf_interface]] object; each one contains a piece of the format string and the corresponding argument. <>= subroutine chop_and_check_format_string (fmt, arg, intf) type(string_t), intent(in) :: fmt type(sprintf_arg_t), dimension(:), intent(in) :: arg type(sprintf_interface_t), dimension(:), intent(out), allocatable :: intf integer :: n_args, i type(string_t), dimension(:), allocatable :: split_fmt type(string_t) :: word, buffer, separator integer :: pos, length, l logical :: ok type(sprintf_arg_t) :: arg_null ok = .true. length = 0 n_args = size (arg) allocate (split_fmt (0:n_args)) split_fmt = "" buffer = fmt SCAN_ARGS: do i = 1, n_args FIND_CONVERSION: do call split (buffer, word, "%", separator=separator) if (separator == "") then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "too few conversion specifiers in format string") ok = .false.; exit SCAN_ARGS end if split_fmt(i-1) = split_fmt(i-1) // word if (extract (buffer, 1, 1) /= "%") then split_fmt(i) = "%" exit FIND_CONVERSION else split_fmt(i-1) = split_fmt(i-1) // "%" end if end do FIND_CONVERSION pos = verify (buffer, "#0-+ ") ! Flag characters (zero or more) split_fmt(i) = split_fmt(i) // extract (buffer, 1, pos-1) buffer = remove (buffer, 1, pos-1) pos = verify (buffer, "123456890") ! Field width word = extract (buffer, 1, pos-1) if (len (word) /= 0) then call read_int_from_string (word, len (word), l) length = length + l end if split_fmt(i) = split_fmt(i) // word buffer = remove (buffer, 1, pos-1) if (extract (buffer, 1, 1) == ".") then buffer = remove (buffer, 1, 1) pos = verify (buffer, "1234567890") ! Precision split_fmt(i) = split_fmt(i) // "." // extract (buffer, 1, pos-1) buffer = remove (buffer, 1, pos-1) end if ! Length modifier would come here, but is not allowed select case (char (extract (buffer, 1, 1))) ! conversion specifier case ("d", "i") if (arg(i)%type /= ARGTYPE_INT) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: integer value expected") ok = .false.; exit SCAN_ARGS end if case ("e", "E", "f", "F", "g", "G") if (arg(i)%type /= ARGTYPE_REAL) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: real value expected") ok = .false.; exit SCAN_ARGS end if case ("s") if (arg(i)%type /= ARGTYPE_STR) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: logical or string value expected") ok = .false.; exit SCAN_ARGS end if case default call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "illegal or incomprehensible conversion specifier") ok = .false.; exit SCAN_ARGS end select split_fmt(i) = split_fmt(i) // extract (buffer, 1, 1) buffer = remove (buffer, 1, 1) end do SCAN_ARGS if (ok) then FIND_EXTRA_CONVERSION: do call split (buffer, word, "%", separator=separator) split_fmt(n_args) = split_fmt(n_args) // word // separator if (separator == "") exit FIND_EXTRA_CONVERSION if (extract (buffer, 1, 1) == "%") then split_fmt(n_args) = split_fmt(n_args) // "%" buffer = remove (buffer, 1, 1) else call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "too many conversion specifiers in format string") ok = .false.; exit FIND_EXTRA_CONVERSION end if end do FIND_EXTRA_CONVERSION split_fmt(n_args) = split_fmt(n_args) // buffer allocate (intf (0:n_args)) call sprintf_interface_init (intf(0), split_fmt(0), arg_null) do i = 1, n_args call sprintf_interface_init (intf(i), split_fmt(i), arg(i)) end do else allocate (intf (0)) end if contains subroutine read_int_from_string (word, length, l) type(string_t), intent(in) :: word integer, intent(in) :: length integer, intent(out) :: l character(len=length) :: buffer buffer = word read (buffer, *) l end subroutine read_int_from_string end subroutine chop_and_check_format_string @ %def chop_and_check_format_string @ \subsection{API} <>= public :: sprintf <>= module function sprintf (fmt, arg) result (string) type(string_t) :: string type(string_t), intent(in) :: fmt type(sprintf_arg_t), dimension(:), intent(in) :: arg end function sprintf <>= module function sprintf (fmt, arg) result (string) type(string_t) :: string type(string_t), intent(in) :: fmt type(sprintf_arg_t), dimension(:), intent(in) :: arg type(sprintf_interface_t), dimension(:), allocatable :: intf integer :: i string = "" call chop_and_check_format_string (fmt, arg, intf) if (size (intf) > 0) then do i = 0, ubound (intf, 1) call sprintf_interface_apply_sprintf (intf(i)) string = string // sprintf_interface_get_result (intf(i)) end do end if end function sprintf @ %def sprintf @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[formats_ut.f90]]>>= <> module formats_ut use unit_tests use formats_uti <> <> contains <> end module formats_ut @ %def formats_ut @ <<[[formats_uti.f90]]>>= <> module formats_uti <> <> use formats <> <> <> contains <> end module formats_uti @ %def formats_ut @ API: driver for the unit tests below. <>= public :: format_test <>= subroutine format_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine format_test @ %def format_test <>= call test (format_1, "format_1", & "check formatting routines", & u, results) <>= public :: format_1 <>= subroutine format_1 (u) integer, intent(in) :: u write (u, "(A)") "*** Test 1: a string ***" write (u, "(A)") call test_run (var_str("%s"), 1, [4], ['abcdefghij'], u) write (u, "(A)") "*** Test 2: two integers ***" write (u, "(A)") call test_run (var_str("%d,%d"), 2, [2, 2], ['42', '13'], u) write (u, "(A)") "*** Test 3: floating point number ***" write (u, "(A)") call test_run (var_str("%8.4f"), 1, [3], ['42567.12345'], u) write (u, "(A)") "*** Test 4: general expression ***" call test_run (var_str("%g"), 1, [3], ['3.1415'], u) contains subroutine test_run (fmt, n_args, type, buffer, unit) type(string_t), intent(in) :: fmt integer, intent(in) :: n_args, unit logical :: lval integer :: ival real(default) :: rval integer :: i type(string_t) :: string type(sprintf_arg_t), dimension(:), allocatable :: arg integer, dimension(n_args), intent(in) :: type character(*), dimension(n_args), intent(in) :: buffer write (unit, "(A,A)") "Format string :", char(fmt) write (unit, "(A,I1)") "Number of args:", n_args allocate (arg (n_args)) do i = 1, n_args write (unit, "(A,I1)") "Argument (type ) = ", type(i) select case (type(i)) case (ARGTYPE_LOG) read (buffer(i), *) lval call sprintf_arg_init (arg(i), lval) case (ARGTYPE_INT) read (buffer(i), *) ival call sprintf_arg_init (arg(i), ival) case (ARGTYPE_REAL) read (buffer(i), *) rval call sprintf_arg_init (arg(i), rval) case (ARGTYPE_STR) call sprintf_arg_init (arg(i), var_str (trim (buffer(i)))) end select end do string = sprintf (fmt, arg) write (unit, "(A,A,A)") "Result: '", char (string), "'" deallocate (arg) end subroutine test_run end subroutine format_1 @ %def format_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{CPU timing} The time is stored in a simple derived type which just holds a floating-point number. <<[[cputime.f90]]>>= <> module cputime <> <> <> <> <> <> interface <> end interface end module cputime @ %def cputime <<[[cputime_sub.f90]]>>= <> submodule (cputime) cputime_s use io_units use diagnostics + implicit none + contains <> end submodule cputime_s @ %def cputime_s @ @ The CPU time is a floating-point number with an arbitrary reference time. It is single precision (default real, not [[real(default)]]). It is measured in seconds. <>= public :: time_t <>= type :: time_t private logical :: known = .false. real :: value = 0 contains <> end type time_t @ %def time_t <>= procedure :: write => time_write <>= module subroutine time_write (object, unit) class(time_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine time_write <>= module subroutine time_write (object, unit) class(time_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "Time in seconds =" if (object%known) then write (u, "(1x,ES10.3)") object%value else write (u, "(1x,A)") "[unknown]" end if end subroutine time_write @ %def time_write @ Set the current time <>= procedure :: set_current => time_set_current <>= module subroutine time_set_current (time) class(time_t), intent(out) :: time end subroutine time_set_current <>= module subroutine time_set_current (time) class(time_t), intent(out) :: time integer :: msecs call system_clock (msecs) time%value = real (msecs) / 1000. time%known = time%value > 0 end subroutine time_set_current @ %def time_set_current @ Assign to a [[real(default]] value. If the time is undefined, return zero. <>= public :: assignment(=) <>= interface assignment(=) module procedure real_assign_time module procedure real_default_assign_time end interface <>= pure module subroutine real_assign_time (r, time) real, intent(out) :: r class(time_t), intent(in) :: time end subroutine real_assign_time pure module subroutine real_default_assign_time (r, time) real(default), intent(out) :: r class(time_t), intent(in) :: time end subroutine real_default_assign_time <>= pure module subroutine real_assign_time (r, time) real, intent(out) :: r class(time_t), intent(in) :: time if (time%known) then r = time%value else r = 0 end if end subroutine real_assign_time pure module subroutine real_default_assign_time (r, time) real(default), intent(out) :: r class(time_t), intent(in) :: time if (time%known) then r = time%value else r = 0 end if end subroutine real_default_assign_time @ %def real_assign_time @ Assign an integer or (single precision) real value to the time object. <>= generic :: assignment(=) => time_assign_from_integer, time_assign_from_real procedure, private :: time_assign_from_integer procedure, private :: time_assign_from_real <>= module subroutine time_assign_from_integer (time, ival) class(time_t), intent(out) :: time integer, intent(in) :: ival end subroutine time_assign_from_integer module subroutine time_assign_from_real (time, rval) class(time_t), intent(out) :: time real, intent(in) :: rval end subroutine time_assign_from_real <>= module subroutine time_assign_from_integer (time, ival) class(time_t), intent(out) :: time integer, intent(in) :: ival time%value = ival time%known = .true. end subroutine time_assign_from_integer module subroutine time_assign_from_real (time, rval) class(time_t), intent(out) :: time real, intent(in) :: rval time%value = rval time%known = .true. end subroutine time_assign_from_real @ %def time_assign_from_real @ Add times and compute time differences. If any input value is undefined, the result is undefined. <>= generic :: operator(-) => subtract_times generic :: operator(+) => add_times procedure, private :: subtract_times procedure, private :: add_times <>= pure module function subtract_times (t_end, t_begin) result (time) type(time_t) :: time class(time_t), intent(in) :: t_end, t_begin end function subtract_times pure module function add_times (t1, t2) result (time) type(time_t) :: time class(time_t), intent(in) :: t1, t2 end function add_times <>= pure module function subtract_times (t_end, t_begin) result (time) type(time_t) :: time class(time_t), intent(in) :: t_end, t_begin if (t_end%known .and. t_begin%known) then time%known = .true. time%value = t_end%value - t_begin%value end if end function subtract_times pure module function add_times (t1, t2) result (time) type(time_t) :: time class(time_t), intent(in) :: t1, t2 if (t1%known .and. t2%known) then time%known = .true. time%value = t1%value + t2%value end if end function add_times @ %def subtract_times @ %def add_times @ Check if a time is known, so we can use it: <>= procedure :: is_known => time_is_known <>= module function time_is_known (time) result (flag) class(time_t), intent(in) :: time logical :: flag end function time_is_known <>= module function time_is_known (time) result (flag) class(time_t), intent(in) :: time logical :: flag flag = time%known end function time_is_known @ %def time_is_known @ We define functions for converting the time into ss / mm:ss / hh:mm:ss / dd:mm:hh:ss. <>= generic :: expand => time_expand_s, time_expand_ms, & time_expand_hms, time_expand_dhms procedure, private :: time_expand_s procedure, private :: time_expand_ms procedure, private :: time_expand_hms procedure, private :: time_expand_dhms <>= module subroutine time_expand_s (time, sec) class(time_t), intent(in) :: time integer, intent(out) :: sec end subroutine time_expand_s module subroutine time_expand_ms (time, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: min, sec end subroutine time_expand_ms module subroutine time_expand_hms (time, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: hour, min, sec end subroutine time_expand_hms module subroutine time_expand_dhms (time, day, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: day, hour, min, sec end subroutine time_expand_dhms <>= module subroutine time_expand_s (time, sec) class(time_t), intent(in) :: time integer, intent(out) :: sec if (time%known) then sec = time%value else call msg_bug ("Time: attempt to expand undefined value") end if end subroutine time_expand_s module subroutine time_expand_ms (time, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: min, sec if (time%known) then if (time%value >= 0) then sec = mod (int (time%value), 60) else sec = - mod (int (- time%value), 60) end if min = time%value / 60 else call msg_bug ("Time: attempt to expand undefined value") end if end subroutine time_expand_ms module subroutine time_expand_hms (time, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: hour, min, sec call time%expand (min, sec) hour = min / 60 if (min >= 0) then min = mod (min, 60) else min = - mod (-min, 60) end if end subroutine time_expand_hms module subroutine time_expand_dhms (time, day, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: day, hour, min, sec call time%expand (hour, min, sec) day = hour / 24 if (hour >= 0) then hour = mod (hour, 24) else hour = - mod (- hour, 24) end if end subroutine time_expand_dhms @ %def time_expand @ Use the above expansions to generate a time string. <>= procedure :: to_string_s => time_to_string_s procedure :: to_string_ms => time_to_string_ms procedure :: to_string_hms => time_to_string_hms procedure :: to_string_dhms => time_to_string_dhms <>= module function time_to_string_s (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str end function time_to_string_s module function time_to_string_ms (time, blank) result (str) class(time_t), intent(in) :: time logical, intent(in), optional :: blank type(string_t) :: str end function time_to_string_ms module function time_to_string_hms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str end function time_to_string_hms module function time_to_string_dhms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str end function time_to_string_dhms <>= module function time_to_string_s (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s call time%expand (s) write (buffer, "(I0,'s')") s str = trim (buffer) end function time_to_string_s module function time_to_string_ms (time, blank) result (str) class(time_t), intent(in) :: time logical, intent(in), optional :: blank type(string_t) :: str character(256) :: buffer integer :: s, m logical :: x_out x_out = .false. if (present (blank)) x_out = blank call time%expand (m, s) write (buffer, "(I0,'m:',I2.2,'s')") m, abs (s) str = trim (buffer) if (x_out) then str = replace (str, len(str)-1, "X") end if end function time_to_string_ms module function time_to_string_hms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s, m, h call time%expand (h, m, s) write (buffer, "(I0,'h:',I2.2,'m:',I2.2,'s')") h, abs (m), abs (s) str = trim (buffer) end function time_to_string_hms module function time_to_string_dhms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s, m, h, d call time%expand (d, h, m, s) write (buffer, "(I0,'d:',I2.2,'h:',I2.2,'m:',I2.2,'s')") & d, abs (h), abs (m), abs (s) str = trim (buffer) end function time_to_string_dhms @ %def time_to_string @ \subsection{Timer} A timer can measure real (wallclock) time differences. The base type corresponds to the result, i.e., time difference. The object contains two further times for start and stop time. <>= public :: timer_t <>= type, extends (time_t) :: timer_t private logical :: running = .false. type(time_t) :: t1, t2 contains <> end type timer_t @ %def timer_t @ Output. If the timer is running, we indicate this, otherwise write just the result. <>= procedure :: write => timer_write <>= module subroutine timer_write (object, unit) class(timer_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine timer_write <>= module subroutine timer_write (object, unit) class(timer_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (object%running) then write (u, "(1x,A)") "Time in seconds = [running]" else call object%time_t%write (u) end if end subroutine timer_write @ %def timer_write @ Start the timer: store the current time in the first entry and adapt the status. We forget any previous values. <>= procedure :: start => timer_start <>= module subroutine timer_start (timer) class(timer_t), intent(out) :: timer end subroutine timer_start <>= module subroutine timer_start (timer) class(timer_t), intent(out) :: timer call timer%t1%set_current () timer%running = .true. end subroutine timer_start @ %def timer_start @ Restart the timer: simply adapt the status, keeping the start time. <>= procedure :: restart => timer_restart <>= module subroutine timer_restart (timer) class(timer_t), intent(inout) :: timer end subroutine timer_restart <>= module subroutine timer_restart (timer) class(timer_t), intent(inout) :: timer if (timer%t1%known .and. .not. timer%running) then timer%running = .true. else call msg_bug ("Timer: restart attempt from wrong status") end if end subroutine timer_restart @ %def timer_start @ Stop the timer: store the current time in the second entry, adapt the status, and compute the elapsed time. <>= procedure :: stop => timer_stop <>= module subroutine timer_stop (timer) class(timer_t), intent(inout) :: timer end subroutine timer_stop <>= module subroutine timer_stop (timer) class(timer_t), intent(inout) :: timer call timer%t2%set_current () timer%running = .false. call timer%evaluate () end subroutine timer_stop @ %def timer_stop @ Manually set the time (for unit test) <>= procedure :: set_test_time1 => timer_set_test_time1 procedure :: set_test_time2 => timer_set_test_time2 <>= module subroutine timer_set_test_time1 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t end subroutine timer_set_test_time1 module subroutine timer_set_test_time2 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t end subroutine timer_set_test_time2 <>= module subroutine timer_set_test_time1 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t timer%t1 = t end subroutine timer_set_test_time1 module subroutine timer_set_test_time2 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t timer%t2 = t end subroutine timer_set_test_time2 @ %def timer_set_test_time1 @ %def timer_set_test_time2 @ This is separate, available for the unit test. <>= procedure :: evaluate => timer_evaluate <>= module subroutine timer_evaluate (timer) class(timer_t), intent(inout) :: timer end subroutine timer_evaluate <>= module subroutine timer_evaluate (timer) class(timer_t), intent(inout) :: timer timer%time_t = timer%t2 - timer%t1 end subroutine timer_evaluate @ %def timer_evaluate @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[cputime_ut.f90]]>>= <> module cputime_ut use unit_tests use cputime_uti <> <> contains <> end module cputime_ut @ %def cputime_ut @ <<[[cputime_uti.f90]]>>= <> module cputime_uti <> use cputime <> <> contains <> end module cputime_uti @ %def cputime_ut @ API: driver for the unit tests below. <>= public :: cputime_test <>= subroutine cputime_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine cputime_test @ %def cputime_test @ \subsubsection{Basic tests} Check basic functions of the time object. The part which we can't check is getting the actual time from the system clock, since the output will not be reproducible. However, we can check time formats and operations. <>= call test (cputime_1, "cputime_1", & "time operations", & u, results) <>= public :: cputime_1 <>= subroutine cputime_1 (u) integer, intent(in) :: u type(time_t) :: time, time1, time2 real :: t integer :: d, h, m, s write (u, "(A)") "* Test output: cputime_1" write (u, "(A)") "* Purpose: check time operations" write (u, "(A)") write (u, "(A)") "* Undefined time" write (u, *) call time%write (u) write (u, *) write (u, "(A)") "* Set time to zero" write (u, *) time = 0 call time%write (u) write (u, *) write (u, "(A)") "* Set time to 1.234 s" write (u, *) time = 1.234 call time%write (u) t = time write (u, "(1x,A,F6.3)") "Time as real =", t write (u, *) write (u, "(A)") "* Compute time difference" write (u, *) time1 = 5.33 time2 = 7.55 time = time2 - time1 call time1%write (u) call time2%write (u) call time%write (u) write (u, *) write (u, "(A)") "* Compute time sum" write (u, *) time = time2 + time1 call time1%write (u) call time2%write (u) call time%write (u) write (u, *) write (u, "(A)") "* Expand time" write (u, *) time1 = ((24 + 1) * 60 + 1) * 60 + 1 time2 = ((3 * 24 + 23) * 60 + 59) * 60 + 59 call time1%expand (s) write (u, 1) "s =", s call time1%expand (m,s) write (u, 1) "ms =", m, s call time1%expand (h,m,s) write (u, 1) "hms =", h, m, s call time1%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s call time2%expand (s) write (u, 1) "s =", s call time2%expand (m,s) write (u, 1) "ms =", m, s call time2%expand (h,m,s) write (u, 1) "hms =", h, m, s call time2%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s write (u, *) write (u, "(A)") "* Expand negative time" write (u, *) time1 = - (((24 + 1) * 60 + 1) * 60 + 1) time2 = - (((3 * 24 + 23) * 60 + 59) * 60 + 59) call time1%expand (s) write (u, 1) "s =", s call time1%expand (m,s) write (u, 1) "ms =", m, s call time1%expand (h,m,s) write (u, 1) "hms =", h, m, s call time1%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s call time2%expand (s) write (u, 1) "s =", s call time2%expand (m,s) write (u, 1) "ms =", m, s call time2%expand (h,m,s) write (u, 1) "hms =", h, m, s call time2%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s 1 format (1x,A,1x,4(I0,:,':')) write (u, *) write (u, "(A)") "* String from time" write (u, *) time1 = ((24 + 1) * 60 + 1) * 60 + 1 time2 = ((3 * 24 + 23) * 60 + 59) * 60 + 59 write (u, "(A)") char (time1%to_string_s ()) write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_hms ()) write (u, "(A)") char (time1%to_string_dhms ()) write (u, "(A)") char (time2%to_string_s ()) write (u, "(A)") char (time2%to_string_ms ()) write (u, "(A)") char (time2%to_string_hms ()) write (u, "(A)") char (time2%to_string_dhms ()) write (u, "(A)") write (u, "(A)") "* Blanking out the last second entry" write (u, "(A)") write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_ms (.true.)) write (u, *) write (u, "(A)") "* String from negative time" write (u, *) time1 = -(((24 + 1) * 60 + 1) * 60 + 1) time2 = -(((3 * 24 + 23) * 60 + 59) * 60 + 59) write (u, "(A)") char (time1%to_string_s ()) write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_hms ()) write (u, "(A)") char (time1%to_string_dhms ()) write (u, "(A)") char (time2%to_string_s ()) write (u, "(A)") char (time2%to_string_ms ()) write (u, "(A)") char (time2%to_string_hms ()) write (u, "(A)") char (time2%to_string_dhms ()) write (u, "(A)") write (u, "(A)") "* Test output end: cputime_1" end subroutine cputime_1 @ %def cputime_1 @ \subsubsection{Timer tests} Check a timer object. <>= call test (cputime_2, "cputime_2", & "timer", & u, results) <>= public :: cputime_2 <>= subroutine cputime_2 (u) integer, intent(in) :: u type(timer_t) :: timer write (u, "(A)") "* Test output: cputime_2" write (u, "(A)") "* Purpose: check timer" write (u, "(A)") write (u, "(A)") "* Undefined timer" write (u, *) call timer%write (u) write (u, *) write (u, "(A)") "* Start timer" write (u, *) call timer%start () call timer%write (u) write (u, *) write (u, "(A)") "* Stop timer (injecting fake timings)" write (u, *) call timer%stop () call timer%set_test_time1 (2) call timer%set_test_time2 (5) call timer%evaluate () call timer%write (u) write (u, *) write (u, "(A)") "* Restart timer" write (u, *) call timer%restart () call timer%write (u) write (u, *) write (u, "(A)") "* Stop timer again (injecting fake timing)" write (u, *) call timer%stop () call timer%set_test_time2 (10) call timer%evaluate () call timer%write (u) write (u, *) write (u, "(A)") "* Test output end: cputime_2" end subroutine cputime_2 @ %def cputime_2 Index: trunk/src/system/Makefile.am =================================================================== --- trunk/src/system/Makefile.am (revision 8771) +++ trunk/src/system/Makefile.am (revision 8772) @@ -1,257 +1,257 @@ ## Makefile.am -- Makefile for WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2021 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## The files in this directory implement OS interactions of WHIZARD ## We create a library which is still to be combined with auxiliary libs. noinst_LTLIBRARIES = libsystem.la check_LTLIBRARIES = libsystem_ut.la COMMON_F90 = \ system_defs.f90 \ signal_interface.c \ sprintf_interface.c \ diagnostics.f90 \ os_interface.f90 \ formats.f90 \ cputime.f90 MPI_F90 = \ os_interface_sub.f90_mpi SERIAL_F90 = \ os_interface_sub.f90_serial SYSTEM_SUBMODULES = \ diagnostics_sub.f90 \ formats_sub.f90 \ cputime_sub.f90 SYSTEM_MODULES = \ system_dependencies.f90 \ debug_master.f90 \ $(COMMON_F90) EXTRA_DIST = \ $(COMMON_F90) \ $(SYSTEM_SUBMODULES) \ $(SERIAL_F90) \ $(MPI_F90) nodist_libsystem_la_SOURCES = \ $(SYSTEM_MODULES) \ $(SYSTEM_SUBMODULES) \ os_interface_sub.f90 DISTCLEANFILES = os_interface_sub.f90 if FC_USE_MPI os_interface_sub.f90: os_interface_sub.f90_mpi -cp -f $< $@ else os_interface_sub.f90: os_interface_sub.f90_serial -cp -f $< $@ endif libsystem_ut_la_SOURCES = \ os_interface_uti.f90 os_interface_ut.f90 \ formats_uti.f90 formats_ut.f90 \ cputime_uti.f90 cputime_ut.f90 ## Omitting this would exclude it from the distribution dist_noinst_DATA = system.nw # Modules and installation # Dump module names into file Modules execmoddir = $(fmoddir)/whizard nodist_execmod_HEADERS = \ system_dependencies.$(FCMOD) \ debug_master.$(FCMOD) \ system_defs.$(FCMOD) \ cputime.$(FCMOD) \ diagnostics.$(FCMOD) \ formats.$(FCMOD) \ os_interface.$(FCMOD) libsystem_Modules = \ $(SYSTEM_MODULES:.f90=) \ $(libsystem_ut_la_SOURCES:.f90=) Modules: Makefile @for module in $(libsystem_Modules); do \ echo $$module >> $@.new; \ done @if diff $@ $@.new -q >/dev/null; then \ rm $@.new; \ else \ mv $@.new $@; echo "Modules updated"; \ fi BUILT_SOURCES = Modules ## Fortran module dependencies # Get module lists from other directories module_lists = \ ../basics/Modules \ ../utilities/Modules \ ../testing/Modules $(module_lists): $(MAKE) -C `dirname $@` Modules Module_dependencies.sed: $(nodist_libsystem_la_SOURCES) $(libsystem_ut_la_SOURCES) Module_dependencies.sed: $(module_lists) @rm -f $@ echo 's/, *only:.*//' >> $@ echo 's/, *&//' >> $@ echo 's/, *.*=>.*//' >> $@ echo 's/$$/.lo/' >> $@ for list in $(module_lists); do \ dir="`dirname $$list`"; \ for mod in `cat $$list`; do \ echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \ done \ done DISTCLEANFILES += Module_dependencies.sed # The following line just says # include Makefile.depend # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE @am__include@ @am__quote@Makefile.depend@am__quote@ Makefile.depend: Module_dependencies.sed Makefile.depend: $(nodist_libsystem_la_SOURCES) $(libsystem_ut_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -f Module_dependencies.sed; \ done > $@ DISTCLEANFILES += Makefile.depend SUFFIXES = .lo .$(FCMOD) # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: # touch $@ AM_FCFLAGS = -I../basics -I../utilities -I../testing ######################################################################## # For the moment, the submodule dependencies will be hard-coded diagnostics_sub.lo: diagnostics.lo os_interface_sub.lo: os_interface.lo formats_sub.lo: formats.lo cputime_sub.lo: cputime.lo ######################################################################## ## Default Fortran compiler options ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif ## MPI if FC_USE_MPI AM_FCFLAGS += $(FCFLAGS_MPI) endif ######################################################################## ## Non-standard targets and dependencies ## (Re)create F90 sources from NOWEB source. if NOWEB_AVAILABLE FILTER = -filter "sed 's/defn MPI:/defn/'" PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw system.stamp: $(PRELUDE) $(srcdir)/system.nw $(POSTLUDE) @rm -f system.tmp @touch system.tmp for src in $(COMMON_F90) $(libsystem_ut_la_SOURCES); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done - for src in $(SYSTEM_SUBMODULES) $(libsystem_ut_la_SOURCES); do \ + for src in $(SYSTEM_SUBMODULES); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done for src in $(SERIAL_F90:.f90_serial=.f90); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src'_serial'; \ done for src in $(MPI_F90:.f90_mpi=.f90); do \ $(NOTANGLE) -R[[$$src]] $(FILTER) $^ | $(CPIF) $$src'_mpi'; \ done @mv -f system.tmp system.stamp $(COMMON_F90) $(SYSTEM_SUBMODULES) $(SERIAL_F90) $(MPI_F90) $(libsystem_ut_la_SOURCES): system.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f system.stamp; \ $(MAKE) $(AM_MAKEFLAGS) system.stamp; \ fi endif ######################################################################## ## Non-standard cleanup tasks ## Remove sources that can be recreated using NOWEB if NOWEB_AVAILABLE maintainer-clean-noweb: -rm -f *.f90 *.f90_serial *.f90_mpi *.c endif .PHONY: maintainer-clean-noweb ## Remove those sources also if builddir and srcdir are different if NOWEB_AVAILABLE clean-noweb: test "$(srcdir)" != "." && rm -f *.f90 *.f90_serial *.f90_mpi *.c || true endif .PHONY: clean-noweb ## Remove F90 module files clean-local: clean-noweb -rm -f system.stamp system.tmp -rm -f *.$(FCMOD) if FC_SUBMODULES -rm -f *.smod *.sub endif ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup Index: trunk/src/qed_pdf/qed_pdf.nw =================================================================== --- trunk/src/qed_pdf/qed_pdf.nw (revision 8771) +++ trunk/src/qed_pdf/qed_pdf.nw (revision 8772) @@ -1,297 +1,299 @@ %% -*- 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 + implicit none + 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 @ Index: trunk/src/combinatorics/combinatorics.nw =================================================================== --- trunk/src/combinatorics/combinatorics.nw (revision 8771) +++ trunk/src/combinatorics/combinatorics.nw (revision 8772) @@ -1,3444 +1,3718 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: combinatorics and such \chapter{Combinatorics} \includemodulegraph{combinatorics} These modules implement standard algorithms (sorting, hashing, etc.) that are not available in Fortran. Fortran doesn't support generic programming, therefore the algorithms are implemented only for specific data types. \begin{description} \item[bytes] Derived types for bytes and words. \item[hashes] Types and tools for setting up hashtables. \item[md5] The MD5 algorithm for message digest. \item[permutations] Permuting an array of integers. \item[sorting] Sorting integer and real values. \item[grids] $d$-dimensional grids can be saved to disk and used for interpolation, maximum finding, etc. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Bytes and such} In a few instances we will need the notion of a byte (8-bit) and a word (32 bit), even a 64-bit word. A block of 512 bit is also needed (for MD5). We rely on integers up to 64 bit being supported by the processor. The main difference to standard integers is the interpretation as unsigned integers. <<[[bytes.f90]]>>= <> module bytes use kinds, only: i8, i32, i64 - use io_units <> <> <> <> <> + interface +<> + end interface + +end module bytes +@ %def bytes +@ +<<[[bytes_sub.f90]]>>= +<> + +submodule (bytes) bytes_s + + use io_units + contains <> -end module bytes -@ %def bytes +end submodule bytes_s + +@ %def bytes_s @ \subsection{8-bit words: bytes} This is essentially a wrapper around 8-bit integers. The wrapper emphasises their special interpretation as a sequence of bits. However, we interpret bytes as unsigned integers. <>= public :: byte_t <>= type :: byte_t private integer(i8) :: i end type byte_t @ %def byte <>= public :: byte_zero <>= type(byte_t), parameter :: byte_zero = byte_t (0_i8) @ %def byte_zero @ Set a byte from 8-bit integer: <>= public :: assignment(=) <>= interface assignment(=) module procedure set_byte_from_i8 end interface @ %def = +<>= + module subroutine set_byte_from_i8 (b, i) + type(byte_t), intent(out) :: b + integer(i8), intent(in) :: i + end subroutine set_byte_from_i8 <>= - subroutine set_byte_from_i8 (b, i) + module subroutine set_byte_from_i8 (b, i) type(byte_t), intent(out) :: b integer(i8), intent(in) :: i b%i = i end subroutine set_byte_from_i8 @ %def set_byte_from_i8 @ Write a byte in one of two formats: either as a hexadecimal number (two digits, default) or as a decimal number (one to three digits). The decimal version is nontrivial because bytes are unsigned integers. Optionally append a newline. <>= public :: byte_write <>= interface byte_write module procedure byte_write_unit, byte_write_string end interface +<>= + module subroutine byte_write_unit (b, unit, decimal, newline) + type(byte_t), intent(in), optional :: b + integer, intent(in), optional :: unit + logical, intent(in), optional :: decimal, newline + end subroutine byte_write_unit <>= - subroutine byte_write_unit (b, unit, decimal, newline) + module subroutine byte_write_unit (b, unit, decimal, newline) type(byte_t), intent(in), optional :: b integer, intent(in), optional :: unit logical, intent(in), optional :: decimal, newline logical :: dc, nl type(word32_t) :: w integer :: u u = given_output_unit (unit); if (u < 0) return dc = .false.; if (present (decimal)) dc = decimal nl = .false.; if (present (newline)) nl = newline if (dc) then w = b write (u, '(I3)', advance='no') w%i else write (u, '(z2.2)', advance='no') b%i end if if (nl) write (u, *) end subroutine byte_write_unit @ %def byte_write_unit @ The string version is hex-only +<>= + module subroutine byte_write_string (b, s) + type(byte_t), intent(in) :: b + character(len=2), intent(inout) :: s + end subroutine byte_write_string <>= - subroutine byte_write_string (b, s) + module subroutine byte_write_string (b, s) type(byte_t), intent(in) :: b character(len=2), intent(inout) :: s write (s, '(z2.2)') b%i end subroutine byte_write_string @ %def byte_write_string @ \subsection{32-bit words} This is not exactly a 32-bit integer. A word is to be filled with bytes, and it may be partially filled. The filling is done lowest-byte first, highest-byte last. We count the bits, so [[fill]] should be either 0, 8, 16, 24, or 32. In printing words, we correspondingly distinguish between printing zeros and printing blanks. <>= public :: word32_t <>= type :: word32_t private integer(i32) :: i integer :: fill = 0 end type word32_t @ %def word32 @ Assignment: the word is filled by inserting a 32-bit integer <>= interface assignment(=) module procedure word32_set_from_i32 module procedure word32_set_from_byte end interface @ %def = +<>= + module subroutine word32_set_from_i32 (w, i) + type(word32_t), intent(out) :: w + integer(i32), intent(in) :: i + end subroutine word32_set_from_i32 <>= - subroutine word32_set_from_i32 (w, i) + module subroutine word32_set_from_i32 (w, i) type(word32_t), intent(out) :: w integer(i32), intent(in) :: i w%i = i w%fill = 32 end subroutine word32_set_from_i32 @ %def word32_set_from_i32 @ Reverse assignment to a 32-bit integer. We do not check the fill status. <>= interface assignment(=) module procedure i32_from_word32 end interface @ %def = +<>= + module subroutine i32_from_word32 (i, w) + integer(i32), intent(out) :: i + type(word32_t), intent(in) :: w + end subroutine i32_from_word32 <>= - subroutine i32_from_word32 (i, w) + module subroutine i32_from_word32 (i, w) integer(i32), intent(out) :: i type(word32_t), intent(in) :: w i = w%i end subroutine i32_from_word32 @ %def i32_from_word32 @ Filling with a 8-bit integer is slightly tricky, because in this interpretation integers are unsigned. +<>= + module subroutine word32_set_from_byte (w, b) + type(word32_t), intent(out) :: w + type(byte_t), intent(in) :: b + end subroutine word32_set_from_byte <>= - subroutine word32_set_from_byte (w, b) + module subroutine word32_set_from_byte (w, b) type(word32_t), intent(out) :: w type(byte_t), intent(in) :: b if (b%i >= 0_i8) then w%i = b%i else w%i = 2_i32*(huge(0_i8)+1_i32) + b%i end if w%fill = 32 end subroutine word32_set_from_byte @ %def word32_set_from_byte @ Check the fill status <>= public :: word32_empty, word32_filled, word32_fill +<>= + module function word32_empty (w) + type(word32_t), intent(in) :: w + logical :: word32_empty + end function word32_empty + module function word32_filled (w) + type(word32_t), intent(in) :: w + logical :: word32_filled + end function word32_filled + module function word32_fill (w) + type(word32_t), intent(in) :: w + integer :: word32_fill + end function word32_fill <>= - function word32_empty (w) + module function word32_empty (w) type(word32_t), intent(in) :: w logical :: word32_empty word32_empty = (w%fill == 0) end function word32_empty - function word32_filled (w) + module function word32_filled (w) type(word32_t), intent(in) :: w logical :: word32_filled word32_filled = (w%fill == 32) end function word32_filled - function word32_fill (w) + module function word32_fill (w) type(word32_t), intent(in) :: w integer :: word32_fill word32_fill = w%fill end function word32_fill @ %def word32_empty word32_filled word32_fill @ Partial assignment: append a byte to a partially filled word. (Note: no assignment if the word is filled, so check this before if necessary.) <>= public :: word32_append_byte +<>= + module subroutine word32_append_byte (w, b) + type(word32_t), intent(inout) :: w + type(byte_t), intent(in) :: b + end subroutine word32_append_byte <>= - subroutine word32_append_byte (w, b) + module subroutine word32_append_byte (w, b) type(word32_t), intent(inout) :: w type(byte_t), intent(in) :: b type(word32_t) :: w1 if (.not. word32_filled (w)) then w1 = b call mvbits (w1%i, 0, 8, w%i, w%fill) w%fill = w%fill + 8 end if end subroutine word32_append_byte @ %def word32_append_byte @ Extract a byte from a word. The argument [[i]] is the position, which may be 0, 1, 2, or 3. For the final assignment, we set the highest bit separately. Otherwise, we might trigger an overflow condition for a compiler with strict checking turned on. <>= public :: byte_from_word32 +<>= + module function byte_from_word32 (w, i) result (b) + type(word32_t), intent(in) :: w + integer, intent(in) :: i + type(byte_t) :: b + end function byte_from_word32 <>= - function byte_from_word32 (w, i) result (b) + module function byte_from_word32 (w, i) result (b) type(word32_t), intent(in) :: w integer, intent(in) :: i type(byte_t) :: b integer(i32) :: j j = 0 if (i >= 0 .and. i*8 < w%fill) then call mvbits (w%i, i*8, 8, j, 0) end if b%i = int (ibclr (j, 7), kind=i8) if (btest (j, 7)) b%i = ibset (b%i, 7) end function byte_from_word32 @ %def byte_from_word32 @ Write a word to file or STDOUT. We understand words as unsigned integers, therefore we cannot use the built-in routine unchanged. However, we can make use of the existence of 64-bit integers and their output routine. In hexadecimal format, the default version prints eight hex characters, highest-first. The [[bytes]] version prints four bytes (two-hex characters), lowest first, with spaces in-between. The decimal bytes version is analogous. In the [[bytes]] version, missing bytes are printed as whitespace. <>= public :: word32_write <>= interface word32_write module procedure word32_write_unit end interface +<>= + module subroutine word32_write_unit (w, unit, bytes, decimal, newline) + type(word32_t), intent(in) :: w + integer, intent(in), optional :: unit + logical, intent(in), optional :: bytes, decimal, newline + end subroutine word32_write_unit <>= - subroutine word32_write_unit (w, unit, bytes, decimal, newline) + module subroutine word32_write_unit (w, unit, bytes, decimal, newline) type(word32_t), intent(in) :: w integer, intent(in), optional :: unit logical, intent(in), optional :: bytes, decimal, newline logical :: dc, by, nl type(word64_t) :: ww integer :: i, u u = given_output_unit (unit); if (u < 0) return by = .false.; if (present (bytes)) by = bytes dc = .false.; if (present (decimal)) dc = decimal nl = .false.; if (present (newline)) nl = newline if (by) then do i = 0, 3 if (i>0) write (u, '(1x)', advance='no') if (8*i < w%fill) then call byte_write (byte_from_word32 (w, i), unit, decimal=decimal) else if (dc) then write (u, '(3x)', advance='no') else write (u, '(2x)', advance='no') end if end do else if (dc) then ww = w write (u, '(I10)', advance='no') ww%i else select case (w%fill) case ( 0) case ( 8); write (6, '(1x,z8.2)', advance='no') ibits (w%i, 0, 8) case (16); write (6, '(1x,z8.4)', advance='no') ibits (w%i, 0,16) case (24); write (6, '(1x,z8.6)', advance='no') ibits (w%i, 0,24) case (32); write (6, '(1x,z8.8)', advance='no') ibits (w%i, 0,32) end select end if if (nl) write (u, *) end subroutine word32_write_unit @ %def word32_write_unit @ \subsection{Operations on 32-bit words} Define the usual logical operations, as well as addition (mod $2^{32}$). We assume that all operands are completely filled. <>= public :: not, ior, ieor, iand, ishft, ishftc <>= interface not module procedure word_not end interface interface ior module procedure word_or end interface interface ieor module procedure word_eor end interface interface iand module procedure word_and end interface interface ishft module procedure word_shft end interface interface ishftc module procedure word_shftc end interface @ %def not, ior, ieor, iand, ishftc +<>= + module function word_not (w1) result (w2) + type(word32_t), intent(in) :: w1 + type(word32_t) :: w2 + end function word_not + module function word_or (w1, w2) result (w3) + type(word32_t), intent(in) :: w1, w2 + type(word32_t) :: w3 + end function word_or + module function word_eor (w1, w2) result (w3) + type(word32_t), intent(in) :: w1, w2 + type(word32_t) :: w3 + end function word_eor + module function word_and (w1, w2) result (w3) + type(word32_t), intent(in) :: w1, w2 + type(word32_t) :: w3 + end function word_and + module function word_shft (w1, s) result (w2) + type(word32_t), intent(in) :: w1 + integer, intent(in) :: s + type(word32_t) :: w2 + end function word_shft + module function word_shftc (w1, s) result (w2) + type(word32_t), intent(in) :: w1 + integer, intent(in) :: s + type(word32_t) :: w2 + end function word_shftc <>= - function word_not (w1) result (w2) + module function word_not (w1) result (w2) type(word32_t), intent(in) :: w1 type(word32_t) :: w2 w2 = not (w1%i) end function word_not - function word_or (w1, w2) result (w3) + module function word_or (w1, w2) result (w3) type(word32_t), intent(in) :: w1, w2 type(word32_t) :: w3 w3 = ior (w1%i, w2%i) end function word_or - function word_eor (w1, w2) result (w3) + module function word_eor (w1, w2) result (w3) type(word32_t), intent(in) :: w1, w2 type(word32_t) :: w3 w3 = ieor (w1%i, w2%i) end function word_eor - function word_and (w1, w2) result (w3) + module function word_and (w1, w2) result (w3) type(word32_t), intent(in) :: w1, w2 type(word32_t) :: w3 w3 = iand (w1%i, w2%i) end function word_and - function word_shft (w1, s) result (w2) + module function word_shft (w1, s) result (w2) type(word32_t), intent(in) :: w1 integer, intent(in) :: s type(word32_t) :: w2 w2 = ishft (w1%i, s) end function word_shft - function word_shftc (w1, s) result (w2) + module function word_shftc (w1, s) result (w2) type(word32_t), intent(in) :: w1 integer, intent(in) :: s type(word32_t) :: w2 w2 = ishftc (w1%i, s, 32) end function word_shftc @ %def word_not word_or word_eor word_and word_shft word_shftc @ Addition is defined mod $2^{32}$, i.e., without overflow checking. This means that we have to work around a possible overflow check enforced by the compiler. <>= public :: operator(+) <>= interface operator(+) module procedure word_add module procedure word_add_i8 module procedure word_add_i32 end interface @ %def + @ +<>= + module function word_add (w1, w2) result (w3) + type(word32_t), intent(in) :: w1, w2 + type(word32_t) :: w3 + end function word_add + module function word_add_i8 (w1, i) result (w3) + type(word32_t), intent(in) :: w1 + integer(i8), intent(in) :: i + type(word32_t) :: w3 + end function word_add_i8 + module function word_add_i32 (w1, i) result (w3) + type(word32_t), intent(in) :: w1 + integer(i32), intent(in) :: i + type(word32_t) :: w3 + end function word_add_i32 <>= - function word_add (w1, w2) result (w3) + module function word_add (w1, w2) result (w3) type(word32_t), intent(in) :: w1, w2 type(word32_t) :: w3 integer(i64) :: j j = int (ibclr (w1%i, 31), i64) + int (ibclr (w2%i, 31), i64) w3 = int (ibclr (j, 31), kind=i32) if (btest (j, 31)) then if (btest (w1%i, 31) .eqv. btest (w2%i, 31)) w3 = ibset (w3%i, 31) else if (btest (w1%i, 31) .neqv. btest (w2%i, 31)) w3 = ibset (w3%i, 31) end if end function word_add - function word_add_i8 (w1, i) result (w3) + module function word_add_i8 (w1, i) result (w3) type(word32_t), intent(in) :: w1 integer(i8), intent(in) :: i type(word32_t) :: w3 integer(i64) :: j j = int (ibclr (w1%i, 31), i64) + int (ibclr (i, 7), i64) if (btest (i, 7)) j = j + 128 w3 = int (ibclr (j, 31), kind=i32) if (btest (j, 31) .neqv. btest (w1%i, 31)) w3 = ibset (w3%i, 31) end function word_add_i8 - function word_add_i32 (w1, i) result (w3) + module function word_add_i32 (w1, i) result (w3) type(word32_t), intent(in) :: w1 integer(i32), intent(in) :: i type(word32_t) :: w3 integer(i64) :: j j = int (ibclr (w1%i, 31), i64) + int (ibclr (i, 31), i64) w3 = int (ibclr (j, 31), kind=i32) if (btest (j, 31)) then if (btest (w1%i, 31) .eqv. btest (i, 31)) w3 = ibset (w3%i, 31) else if (btest (w1%i, 31) .neqv. btest (i, 31)) w3 = ibset (w3%i, 31) end if end function word_add_i32 @ %def word_add word_add_i32 @ \subsection{64-bit words} These objects consist of two 32-bit words. They thus can hold integer numbers larger than $2^{32}$ (to be exact, $2^{31}$ since FORTRAN integers are signed). The order is low-word, high-word. <>= public :: word64_t <>= type :: word64_t private integer(i64) :: i end type word64_t @ %def word64 @ Set a 64 bit word: <>= interface assignment(=) module procedure word64_set_from_i64 module procedure word64_set_from_word32 end interface @ %def = +<>= + module subroutine word64_set_from_i64 (ww, i) + type(word64_t), intent(out) :: ww + integer(i64), intent(in) :: i + end subroutine word64_set_from_i64 <>= - subroutine word64_set_from_i64 (ww, i) + module subroutine word64_set_from_i64 (ww, i) type(word64_t), intent(out) :: ww integer(i64), intent(in) :: i ww%i = i end subroutine word64_set_from_i64 @ %def word64_set_from_i64 @ Filling with a 32-bit word: +<>= + module subroutine word64_set_from_word32 (ww, w) + type(word64_t), intent(out) :: ww + type(word32_t), intent(in) :: w + end subroutine word64_set_from_word32 <>= - subroutine word64_set_from_word32 (ww, w) + module subroutine word64_set_from_word32 (ww, w) type(word64_t), intent(out) :: ww type(word32_t), intent(in) :: w if (w%i >= 0_i32) then ww%i = w%i else ww%i = 2_i64*(huge(0_i32)+1_i64) + w%i end if end subroutine word64_set_from_word32 @ %def word64_set_from_word32 @ Extract a byte from a word. The argument [[i]] is the position, which may be between 0 and 7. For the final assignment, we set the highest bit separately. Otherwise, we might trigger an overflow condition for a compiler with strict checking turned on. <>= public :: byte_from_word64, word32_from_word64 +<>= + module function byte_from_word64 (ww, i) result (b) + type(word64_t), intent(in) :: ww + integer, intent(in) :: i + type(byte_t) :: b + end function byte_from_word64 <>= - function byte_from_word64 (ww, i) result (b) + module function byte_from_word64 (ww, i) result (b) type(word64_t), intent(in) :: ww integer, intent(in) :: i type(byte_t) :: b integer(i64) :: j j = 0 if (i >= 0 .and. i*8 < 64) then call mvbits (ww%i, i*8, 8, j, 0) end if b%i = int (ibclr (j, 7), kind=i8) if (btest (j, 7)) b%i = ibset (b%i, 7) end function byte_from_word64 @ %def byte_from_word64 @ Extract a 32-bit word from a 64-bit word. The position is either 0 or 1. +<>= + module function word32_from_word64 (ww, i) result (w) + type(word64_t), intent(in) :: ww + integer, intent(in) :: i + type(word32_t) :: w + end function word32_from_word64 <>= - function word32_from_word64 (ww, i) result (w) + module function word32_from_word64 (ww, i) result (w) type(word64_t), intent(in) :: ww integer, intent(in) :: i type(word32_t) :: w integer(i64) :: j j = 0 select case (i) case (0); call mvbits (ww%i, 0, 32, j, 0) case (1); call mvbits (ww%i, 32, 32, j, 0) end select w = int (ibclr (j, 31), kind=i32) if (btest (j, 31)) w = ibset (w%i, 31) end function word32_from_word64 @ %def word32_from_word64 @ Print a 64-bit word. Decimal version works up to $2^{63}$. The [[words]] version uses the 'word32' printout, separated by two spaces. The low-word is printed first. The [[bytes]] version also uses the 'word32' printout. This implies that the lowest byte is first. The default version prints a hexadecimal number without spaces, highest byte first. <>= public :: word64_write <>= interface word64_write module procedure word64_write_unit end interface +<>= + module subroutine word64_write_unit (ww, unit, words, bytes, decimal, newline) + type(word64_t), intent(in) :: ww + integer, intent(in), optional :: unit + logical, intent(in), optional :: words, bytes, decimal, newline + end subroutine word64_write_unit <>= - subroutine word64_write_unit (ww, unit, words, bytes, decimal, newline) + module subroutine word64_write_unit (ww, unit, words, bytes, decimal, newline) type(word64_t), intent(in) :: ww integer, intent(in), optional :: unit logical, intent(in), optional :: words, bytes, decimal, newline logical :: wo, by, dc, nl integer :: u u = given_output_unit (unit); if (u < 0) return wo = .false.; if (present (words)) wo = words by = .false.; if (present (bytes)) by = bytes dc = .false.; if (present (decimal)) dc = decimal nl = .false.; if (present (newline)) nl = newline if (wo .or. by) then call word32_write_unit (word32_from_word64 (ww, 0), unit, by, dc) write (u, '(2x)', advance='no') call word32_write_unit (word32_from_word64 (ww, 1), unit, by, dc) else if (dc) then write (u, '(I19)', advance='no') ww%i else write (u, '(Z16)', advance='no') ww%i end if if (nl) write (u, *) end subroutine word64_write_unit @ %def word64_write_unit @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Hashtables} Hash tables, like lists, are not part of Fortran and must be defined on a per-case basis. In this section we define a module that contains a hash function. Furthermore, for reference there is a complete framework of hashtable type definitions and access functions. This code is to be replicated where hash tables are used, mutatis mutandis. <<[[hashes.f90]]>>= <> module hashes use kinds, only: i8, i32 - use bytes <> <> + interface +<> + end interface + +end module hashes +@ %def hashes +@ +<<[[hashes_sub.f90]]>>= +<> + +submodule (hashes) hashes_s + + use bytes + contains <> -end module hashes -@ %def hashes +end submodule hashes_s + +@ %def hashes_s @ \subsection{The hash function} This is the one-at-a-time hash function by Bob Jenkins (from Wikipedia), re-implemented in Fortran. The function works on an array of bytes (8-bit integers), as could be produced by, e.g., the [[transfer]] function, and returns a single 32-bit integer. For determining the position in a hashtable, one can pick the lower bits of the result as appropriate to the hashtable size (which should be a power of 2). Note that we are working on signed integers, so the interpretation of values differs from the C version. This should not matter in practice, however. <>= public :: hash +<>= + module function hash (key) result (hashval) + integer(i32) :: hashval + integer(i8), dimension(:), intent(in) :: key + end function hash <>= - function hash (key) result (hashval) + module function hash (key) result (hashval) integer(i32) :: hashval integer(i8), dimension(:), intent(in) :: key type(word32_t) :: w integer :: i w = 0_i32 do i = 1, size (key) w = w + key(i) w = w + ishft (w, 10) w = ieor (w, ishft (w, -6)) end do w = w + ishft (w, 3) w = ieor (w, ishft (w, -11)) w = w + ishft (w, 15) hashval = w end function hash @ %def hash @ \subsection{The hash table} We define a generic hashtable type (that depends on the [[hash_data_t]] type) together with associated methods. This is a template: <>= type :: hash_data_t integer :: i end type hash_data_t @ %def hash_data_t @ Associated methods: <>= subroutine hash_data_final (data) type(hash_data_t), intent(inout) :: data end subroutine hash_data_final subroutine hash_data_write (data, unit) type(hash_data_t), intent(in) :: data integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, *) data%i end subroutine hash_data_write @ %def hash_data_final hash_data_write @ Each hash entry stores the unmasked hash value, the key, and points to actual data if present. Note that this could be an allocatable scalar in principle, but making it a pointer avoids deep copy when expanding the hashtable. <>= type :: hash_entry_t integer(i32) :: hashval = 0 integer(i8), dimension(:), allocatable :: key type(hash_data_t), pointer :: data => null () end type hash_entry_t @ %def hash_entry_t @ The hashtable object holds the actual table, the number of filled entries and the number of entries after which the size should be doubled. The mask is equal to the table size minus one and thus coincides with the upper bound of the table index, which starts at zero. <>= type :: hashtable_t integer :: n_entries = 0 real :: fill_ratio = 0 integer :: n_entries_max = 0 integer(i32) :: mask = 0 type(hash_entry_t), dimension(:), allocatable :: entry end type hashtable_t @ %def hashtable_t @ Initializer: The size has to be a power of two, the fill ratio is a real (machine-default!) number between 0 and 1. <>= subroutine hashtable_init (hashtable, size, fill_ratio) type(hashtable_t), intent(out) :: hashtable integer, intent(in) :: size real, intent(in) :: fill_ratio hashtable%fill_ratio = fill_ratio hashtable%n_entries_max = size * fill_ratio hashtable%mask = size - 1 allocate (hashtable%entry (0:hashtable%mask)) end subroutine hashtable_init @ %def hashtable_init @ Finalizer: This calls a [[hash_data_final]] subroutine which must exist. <>= subroutine hashtable_final (hashtable) type(hashtable_t), intent(inout) :: hashtable integer :: i do i = 0, hashtable%mask if (associated (hashtable%entry(i)%data)) then call hash_data_final (hashtable%entry(i)%data) deallocate (hashtable%entry(i)%data) end if end do deallocate (hashtable%entry) end subroutine hashtable_final @ %def hashtable_final @ Output. Here, we refer to a [[hash_data_write]] subroutine. <>= subroutine hashtable_write (hashtable, unit) type(hashtable_t), intent(in) :: hashtable integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return do i = 0, hashtable%mask if (associated (hashtable%entry(i)%data)) then write (u, *) i, "(hash =", hashtable%entry(i)%hashval, ")", & hashtable%entry(i)%key call hash_data_write (hashtable%entry(i)%data, unit) end if end do end subroutine hashtable_write @ %def hashtable_write @ \subsection{Hashtable insertion} Insert a single entry with the hash value as trial place. If the table is filled, first expand it. <>= subroutine hashtable_insert (hashtable, key, data) type(hashtable_t), intent(inout) :: hashtable integer(i8), dimension(:), intent(in) :: key type(hash_data_t), intent(in), target :: data integer(i32) :: h if (hashtable%n_entries >= hashtable%n_entries_max) & call hashtable_expand (hashtable) h = hash (key) call hashtable_insert_rec (hashtable, h, h, key, data) end subroutine hashtable_insert @ %def hashtable_insert @ We need this auxiliary routine for doubling the size of the hashtable. We rely on the fact that default assignment copies the data pointer, not the data themselves. The temporary array must not be finalized; it is deallocated automatically together with its allocatable components. <>= subroutine hashtable_expand (hashtable) type(hashtable_t), intent(inout) :: hashtable type(hash_entry_t), dimension(:), allocatable :: table_tmp integer :: i, s allocate (table_tmp (0:hashtable%mask)) table_tmp = hashtable%entry deallocate (hashtable%entry) s = 2 * size (table_tmp) hashtable%n_entries = 0 hashtable%n_entries_max = s * hashtable%fill_ratio hashtable%mask = s - 1 allocate (hashtable%entry (0:hashtable%mask)) do i = 0, ubound (table_tmp, 1) if (associated (table_tmp(i)%data)) then call hashtable_insert_rec (hashtable, table_tmp(i)%hashval, & table_tmp(i)%hashval, table_tmp(i)%key, table_tmp(i)%data) end if end do end subroutine hashtable_expand @ %def hashtable_expand @ Insert a single entry at a trial place [[h]], reduced to the table size. Collision resolution is done simply by choosing the next element, recursively until the place is empty. For bookkeeping, we preserve the original hash value. For a good hash function, there should be no clustering. Note that if the new key exactly matches an existing key, nothing is done. <>= recursive subroutine hashtable_insert_rec (hashtable, h, hashval, key, data) type(hashtable_t), intent(inout) :: hashtable integer(i32), intent(in) :: h, hashval integer(i8), dimension(:), intent(in) :: key type(hash_data_t), intent(in), target :: data integer(i32) :: i i = iand (h, hashtable%mask) if (associated (hashtable%entry(i)%data)) then if (size (hashtable%entry(i)%key) /= size (key)) then call hashtable_insert_rec (hashtable, h + 1, hashval, key, data) else if (any (hashtable%entry(i)%key /= key)) then call hashtable_insert_rec (hashtable, h + 1, hashval, key, data) end if else hashtable%entry(i)%hashval = hashval allocate (hashtable%entry(i)%key (size (key))) hashtable%entry(i)%key = key hashtable%entry(i)%data => data hashtable%n_entries = hashtable%n_entries + 1 end if end subroutine hashtable_insert_rec @ %def hashtable_insert_rec @ \subsection{Hashtable lookup} The lookup function has to parallel the insert function. If the place is filled, check if the key matches. Yes: return the pointer; no: increment the hash value and check again. <>= function hashtable_lookup (hashtable, key) result (ptr) type(hash_data_t), pointer :: ptr type(hashtable_t), intent(in) :: hashtable integer(i8), dimension(:), intent(in) :: key ptr => hashtable_lookup_rec (hashtable, hash (key), key) end function hashtable_lookup @ %def hashtable_get_data_ptr <>= recursive function hashtable_lookup_rec (hashtable, h, key) result (ptr) type(hash_data_t), pointer :: ptr type(hashtable_t), intent(in) :: hashtable integer(i32), intent(in) :: h integer(i8), dimension(:), intent(in) :: key integer(i32) :: i i = iand (h, hashtable%mask) if (associated (hashtable%entry(i)%data)) then if (size (hashtable%entry(i)%key) == size (key)) then if (all (hashtable%entry(i)%key == key)) then ptr => hashtable%entry(i)%data else ptr => hashtable_lookup_rec (hashtable, h + 1, key) end if else ptr => hashtable_lookup_rec (hashtable, h + 1, key) end if else ptr => null () end if end function hashtable_lookup_rec @ %def hashtable_lookup_rec <>= public :: hashtable_test <>= subroutine hashtable_test () type(hash_data_t), pointer :: data type(hashtable_t) :: hashtable integer(i8) :: i call hashtable_init (hashtable, 16, 0.25) do i = 1, 10 allocate (data) data%i = i*i call hashtable_insert (hashtable, [i, i+i], data) end do call hashtable_insert (hashtable, [2_i8, 4_i8], data) call hashtable_write (hashtable) data => hashtable_lookup (hashtable, [5_i8, 10_i8]) if (associated (data)) then print *, "lookup:", data%i else print *, "lookup: --" end if data => hashtable_lookup (hashtable, [6_i8, 12_i8]) if (associated (data)) then print *, "lookup:", data%i else print *, "lookup: --" end if data => hashtable_lookup (hashtable, [4_i8, 9_i8]) if (associated (data)) then print *, "lookup:", data%i else print *, "lookup: --" end if call hashtable_final (hashtable) end subroutine hashtable_test @ %def hashtable_test @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{MD5 Checksums} Implementing MD5 checksums allows us to check input/file integrity on the basis of a well-known standard. The building blocks have been introduced in the [[bytes]] module. <<[[md5.f90]]>>= <> module md5 - use kinds, only: i8, i32, i64 - use io_units - use system_defs, only: BUFFER_SIZE - use system_defs, only: LF, EOR, EOF - use diagnostics use bytes <> <> <> -<> - <> + interface +<> + end interface + +end module md5 +@ %def md5 +@ +<<[[md5_sub.f90]]>>= +<> + +submodule (md5) md5_s + + use kinds, only: i8, i32, i64 + use system_defs, only: BUFFER_SIZE + use system_defs, only: LF, EOR, EOF + use io_units + use diagnostics + +<> + contains <> -end module md5 -@ %def md5 +end submodule md5_s + +@ %def md5_s @ \subsection{Blocks} A block is a sequence of 16 words (64 bytes or 512 bits). We anticipate that blocks will be linked, so include a pointer to the next block. There is a fill status (word counter), as there is one for each word. The fill status is equal to the number of bytes that are in, so it may be between 0 and 64. <>= type :: block_t private type(word32_t), dimension(0:15) :: w type(block_t), pointer :: next => null () integer :: fill = 0 end type block_t @ %def block @ Check if a block is completely filled or empty: <>= function block_is_empty (b) type(block_t), intent(in) :: b logical :: block_is_empty block_is_empty = (b%fill == 0 .and. word32_empty (b%w(0))) end function block_is_empty function block_is_filled (b) type(block_t), intent(in) :: b logical :: block_is_filled block_is_filled = (b%fill == 64) end function block_is_filled @ %def block_is_empty block_is_filled @ Append a single byte to a block. Works only if the block is not yet filled. <>= subroutine block_append_byte (bl, by) type(block_t), intent(inout) :: bl type(byte_t), intent(in) :: by if (.not. block_is_filled (bl)) then call word32_append_byte (bl%w(bl%fill/4), by) bl%fill = bl%fill + 1 end if end subroutine block_append_byte @ %def block_append_byte @ The printing routine allows for printing as sequences of words or bytes, decimal or hex. <>= interface block_write module procedure block_write_unit end interface +<>= + module subroutine block_write_unit (b, unit, bytes, decimal) + type(block_t), intent(in) :: b + integer, intent(in), optional :: unit + logical, intent(in), optional :: bytes, decimal + end subroutine block_write_unit <>= - subroutine block_write_unit (b, unit, bytes, decimal) + module subroutine block_write_unit (b, unit, bytes, decimal) type(block_t), intent(in) :: b integer, intent(in), optional :: unit logical, intent(in), optional :: bytes, decimal logical :: by, dc integer :: i, u u = given_output_unit (unit); if (u < 0) return by = .false.; if (present (bytes)) by = bytes dc = .false.; if (present (decimal)) dc = decimal do i = 0, b%fill/4 - 1 call newline_or_blank (u, i, by, dc) call word32_write (b%w(i), unit, bytes, decimal) end do if (.not. block_is_filled (b)) then i = b%fill/4 if (.not. word32_empty (b%w(i))) then call newline_or_blank (u, i, by, dc) call word32_write (b%w(i), unit, bytes, decimal) end if end if write (u, *) contains subroutine newline_or_blank (u, i, bytes, decimal) integer, intent(in) :: u, i logical, intent(in) :: bytes, decimal if (decimal) then select case (i) case (0) case (2,4,6,8,10,12,14); write (u, *) case default write (u, '(2x)', advance='no') end select else if (bytes) then select case (i) case (0) case (4,8,12); write (u, *) case default write (u, '(2x)', advance='no') end select else if (i == 8) write (u, *) end if end subroutine newline_or_blank end subroutine block_write_unit @ %def block_write_unit @ \subsection{Messages} A message (within this module) is a linked list of blocks. <>= type :: message_t private type(block_t), pointer :: first => null () type(block_t), pointer :: last => null () integer :: n_blocks = 0 end type message_t @ %def message_t @ Clear the message list <>= subroutine message_clear (m) type(message_t), intent(inout) :: m type(block_t), pointer :: b nullify (m%last) do b => m%first if (.not.(associated (b))) exit m%first => b%next deallocate (b) end do m%n_blocks = 0 end subroutine message_clear @ %def message_clear @ Append an empty block to the message list <>= subroutine message_append_new_block (m) type(message_t), intent(inout) :: m if (associated (m%last)) then allocate (m%last%next) m%last => m%last%next m%n_blocks = m%n_blocks + 1 else allocate (m%first) m%last => m%first m%n_blocks = 1 end if end subroutine message_append_new_block @ %def message_append_new_block @ Initialize: clear and allocate the first (empty) block. <>= subroutine message_init (m) type(message_t), intent(inout) :: m call message_clear (m) call message_append_new_block (m) end subroutine message_init @ %def message_init @ Append a single byte to a message. If necessary, allocate a new block. If the message is empty, initialize it. <>= subroutine message_append_byte (m, b) type(message_t), intent(inout) :: m type(byte_t), intent(in) :: b if (.not. associated (m%last)) then call message_init (m) else if (block_is_filled (m%last)) then call message_append_new_block (m) end if call block_append_byte (m%last, b) end subroutine message_append_byte @ %def message_append_byte @ Append zero bytes until the current block is filled up to the required position. If we are already beyond that, append a new block and fill that one. <>= subroutine message_pad_zero (m, i) type(message_t), intent(inout) :: m integer, intent(in) :: i type(block_t), pointer :: b integer :: j if (associated (m%last)) then b => m%last if (b%fill > i) then do j = b%fill + 1, 64 + i call message_append_byte (m, byte_zero) end do else do j = b%fill + 1, i call message_append_byte (m, byte_zero) end do end if end if end subroutine message_pad_zero @ %def message_pad_zero @ This returns the number of bits within a message. We need a 64-bit word for the result since it may be more than $2^{31}$. This is also required by the MD5 standard. <>= function message_bits (m) result (length) type(message_t), intent(in) :: m type(word64_t) :: length type(block_t), pointer :: b integer(i64) :: n_blocks_filled, n_bytes_extra if (m%n_blocks > 0) then b => m%last if (block_is_filled (b)) then n_blocks_filled = m%n_blocks n_bytes_extra = 0 else n_blocks_filled = m%n_blocks - 1 n_bytes_extra = b%fill end if length = n_blocks_filled * 512 + n_bytes_extra * 8 else length = 0_i64 end if end function message_bits @ %def message_bits @ \subsection{Message I/O} Append the contents of a string to a message. We first cast the character string into a 8-bit integer array and the append this byte by byte. <>= subroutine message_append_string (m, s) type(message_t), intent(inout) :: m character(len=*), intent(in) :: s integer(i64) :: i, n_bytes integer(i8), dimension(:), allocatable :: buffer integer(i8), dimension(1) :: mold type(byte_t) :: b n_bytes = size (transfer (s, mold)) allocate (buffer (n_bytes)) buffer = transfer (s, mold) do i = 1, size (buffer) b = buffer(i) call message_append_byte (m, b) end do deallocate (buffer) end subroutine message_append_string @ %def message_append_string @ Append the contents of a 32-bit integer to a message. We first cast the 32-bit integer into a 8-bit integer array and the append this byte by byte. <>= subroutine message_append_i32 (m, x) type(message_t), intent(inout) :: m integer(i32), intent(in) :: x integer(i8), dimension(4) :: buffer type(byte_t) :: b integer :: i buffer = transfer (x, buffer, size(buffer)) do i = 1, size (buffer) b = buffer(i) call message_append_byte (m, b) end do end subroutine message_append_i32 @ %def message_append_i32 @ Append one line from file to a message. Include the newline character. <>= subroutine message_append_from_unit (m, u, iostat) type(message_t), intent(inout) :: m integer, intent(in) :: u integer, intent(out) :: iostat character(len=BUFFER_SIZE) :: buffer read (u, *, iostat=iostat) buffer call message_append_string (m, trim (buffer)) call message_append_string (m, LF) end subroutine message_append_from_unit @ %def message_append_from_unit @ Fill a message from file. (Each line counts as a string.) <>= subroutine message_read_from_file (m, f) type(message_t), intent(inout) :: m character(len=*), intent(in) :: f integer :: u, iostat u = free_unit () open (file=f, unit=u, action='read') do call message_append_from_unit (m, u, iostat=iostat) if (iostat < 0) exit end do close (u) end subroutine message_read_from_file @ %def message_read_from_file @ Write a message. After each block, insert an empty line. <>= interface message_write module procedure message_write_unit end interface +<>= + module subroutine message_write_unit (m, unit, bytes, decimal) + type(message_t), intent(in) :: m + integer, intent(in), optional :: unit + logical, intent(in), optional :: bytes, decimal + end subroutine message_write_unit <>= - subroutine message_write_unit (m, unit, bytes, decimal) + module subroutine message_write_unit (m, unit, bytes, decimal) type(message_t), intent(in) :: m integer, intent(in), optional :: unit logical, intent(in), optional :: bytes, decimal type(block_t), pointer :: b integer :: u u = given_output_unit (unit); if (u < 0) return b => m%first if (associated (b)) then do call block_write_unit (b, unit, bytes, decimal) b => b%next if (.not. associated (b)) exit write (u, *) end do end if end subroutine message_write_unit @ %def message_write_unit @ \subsection{Auxiliary functions} These four functions on three words are defined in the MD5 standard: <>= function ff (x, y, z) type(word32_t), intent(in) :: x, y, z type(word32_t) :: ff ff = ior (iand (x, y), iand (not (x), z)) end function ff function fg (x, y, z) type(word32_t), intent(in) :: x, y, z type(word32_t) :: fg fg = ior (iand (x, z), iand (y, not (z))) end function fg function fh (x, y, z) type(word32_t), intent(in) :: x, y, z type(word32_t) :: fh fh = ieor (ieor (x, y), z) end function fh function fi (x, y, z) type(word32_t), intent(in) :: x, y, z type(word32_t) :: fi fi = ieor (y, ior (x, not (z))) end function fi @ %def ff fg fh fi @ \subsection{Auxiliary stuff} This defines and initializes the table of transformation constants: <>= type(word32_t), dimension(64), save :: t logical, save :: table_initialized = .false. @ %def t table_initialized <>= subroutine table_init type(word64_t) :: ww integer :: i if (.not.table_initialized) then do i = 1, 64 ww = int (4294967296d0 * abs (sin (i * 1d0)), kind=i64) t(i) = word32_from_word64 (ww, 0) end do table_initialized = .true. end if end subroutine table_init @ %def table_init @ This encodes the message digest (4 words) into a 32-character string. <>= function digest_string (aa) result (s) type(word32_t), dimension (0:3), intent(in) :: aa character(len=32) :: s integer :: i, j do i = 0, 3 do j = 0, 3 call byte_write (byte_from_word32 (aa(i), j), s(i*8+j*2+1:i*8+j*2+2)) end do end do end function digest_string @ %def digest_string @ \subsection{MD5 algorithm} Pad the message with a byte [[x80]] and then pad zeros up to a full block minus two words; in these words, insert the message length (before padding) as a 64-bit word, low-word first. <>= subroutine message_pad (m) type(message_t), intent(inout) :: m type(word64_t) :: length integer(i8), parameter :: ipad = -128 ! z'80' type(byte_t) :: b integer :: i length = message_bits (m) b = ipad call message_append_byte (m, b) call message_pad_zero (m, 56) do i = 0, 7 call message_append_byte (m, byte_from_word64 (length, i)) end do end subroutine message_pad @ %def message_pad @ Apply a series of transformations onto a state [[a,b,c,d]], where the transform function uses each word of the message together with the predefined words. Finally, encode the state as a 32-character string. <>= subroutine message_digest (m, s) type(message_t), intent(in) :: m character(len=32), intent(out) :: s integer(i32), parameter :: ia = 1732584193 ! z'67452301' integer(i32), parameter :: ib = -271733879 ! z'efcdab89' integer(i32), parameter :: ic = -1732584194 ! z'98badcfe' integer(i32), parameter :: id = 271733878 ! z'10325476' type(word32_t) :: a, b, c, d type(word32_t) :: aa, bb, cc, dd type(word32_t), dimension(0:15) :: x type(block_t), pointer :: bl call table_init a = ia; b = ib; c = ic; d = id bl => m%first do if (.not.associated (bl)) exit x = bl%w aa = a; bb = b; cc = c; dd = d call transform (ff, a, b, c, d, 0, 7, 1) call transform (ff, d, a, b, c, 1, 12, 2) call transform (ff, c, d, a, b, 2, 17, 3) call transform (ff, b, c, d, a, 3, 22, 4) call transform (ff, a, b, c, d, 4, 7, 5) call transform (ff, d, a, b, c, 5, 12, 6) call transform (ff, c, d, a, b, 6, 17, 7) call transform (ff, b, c, d, a, 7, 22, 8) call transform (ff, a, b, c, d, 8, 7, 9) call transform (ff, d, a, b, c, 9, 12, 10) call transform (ff, c, d, a, b, 10, 17, 11) call transform (ff, b, c, d, a, 11, 22, 12) call transform (ff, a, b, c, d, 12, 7, 13) call transform (ff, d, a, b, c, 13, 12, 14) call transform (ff, c, d, a, b, 14, 17, 15) call transform (ff, b, c, d, a, 15, 22, 16) call transform (fg, a, b, c, d, 1, 5, 17) call transform (fg, d, a, b, c, 6, 9, 18) call transform (fg, c, d, a, b, 11, 14, 19) call transform (fg, b, c, d, a, 0, 20, 20) call transform (fg, a, b, c, d, 5, 5, 21) call transform (fg, d, a, b, c, 10, 9, 22) call transform (fg, c, d, a, b, 15, 14, 23) call transform (fg, b, c, d, a, 4, 20, 24) call transform (fg, a, b, c, d, 9, 5, 25) call transform (fg, d, a, b, c, 14, 9, 26) call transform (fg, c, d, a, b, 3, 14, 27) call transform (fg, b, c, d, a, 8, 20, 28) call transform (fg, a, b, c, d, 13, 5, 29) call transform (fg, d, a, b, c, 2, 9, 30) call transform (fg, c, d, a, b, 7, 14, 31) call transform (fg, b, c, d, a, 12, 20, 32) call transform (fh, a, b, c, d, 5, 4, 33) call transform (fh, d, a, b, c, 8, 11, 34) call transform (fh, c, d, a, b, 11, 16, 35) call transform (fh, b, c, d, a, 14, 23, 36) call transform (fh, a, b, c, d, 1, 4, 37) call transform (fh, d, a, b, c, 4, 11, 38) call transform (fh, c, d, a, b, 7, 16, 39) call transform (fh, b, c, d, a, 10, 23, 40) call transform (fh, a, b, c, d, 13, 4, 41) call transform (fh, d, a, b, c, 0, 11, 42) call transform (fh, c, d, a, b, 3, 16, 43) call transform (fh, b, c, d, a, 6, 23, 44) call transform (fh, a, b, c, d, 9, 4, 45) call transform (fh, d, a, b, c, 12, 11, 46) call transform (fh, c, d, a, b, 15, 16, 47) call transform (fh, b, c, d, a, 2, 23, 48) call transform (fi, a, b, c, d, 0, 6, 49) call transform (fi, d, a, b, c, 7, 10, 50) call transform (fi, c, d, a, b, 14, 15, 51) call transform (fi, b, c, d, a, 5, 21, 52) call transform (fi, a, b, c, d, 12, 6, 53) call transform (fi, d, a, b, c, 3, 10, 54) call transform (fi, c, d, a, b, 10, 15, 55) call transform (fi, b, c, d, a, 1, 21, 56) call transform (fi, a, b, c, d, 8, 6, 57) call transform (fi, d, a, b, c, 15, 10, 58) call transform (fi, c, d, a, b, 6, 15, 59) call transform (fi, b, c, d, a, 13, 21, 60) call transform (fi, a, b, c, d, 4, 6, 61) call transform (fi, d, a, b, c, 11, 10, 62) call transform (fi, c, d, a, b, 2, 15, 63) call transform (fi, b, c, d, a, 9, 21, 64) a = a + aa b = b + bb c = c + cc d = d + dd bl => bl%next end do s = digest_string ([a, b, c, d]) contains <> end subroutine message_digest @ %def message_digest @ And this is the actual transformation that depends on one of the previous functions, four words, and three integers. The implicit arguments are [[x]], the word from the message to digest, and [[t]], the entry in the predefined table. <>= subroutine transform (f, a, b, c, d, k, s, i) interface function f (x, y, z) import word32_t type(word32_t), intent(in) :: x, y, z type(word32_t) :: f end function f end interface type(word32_t), intent(inout) :: a type(word32_t), intent(in) :: b, c, d integer, intent(in) :: k, s, i a = b + ishftc (a + f(b, c, d) + x(k) + t(i), s) end subroutine transform @ %def transform @ \subsection{User interface} <>= public :: md5sum <>= interface md5sum module procedure md5sum_from_string module procedure md5sum_from_unit end interface @ %def md5sum @ This function computes the MD5 sum of the input string and returns it as a 32-character string +<>= + module function md5sum_from_string (s) result (digest) + character(len=*), intent(in) :: s + character(len=32) :: digest + end function md5sum_from_string <>= - function md5sum_from_string (s) result (digest) + module function md5sum_from_string (s) result (digest) character(len=*), intent(in) :: s character(len=32) :: digest type(message_t) :: m call message_append_string (m, s) call message_pad (m) call message_digest (m, digest) call message_clear (m) end function md5sum_from_string @ %def md5sum_from_string @ This funct. reads from unit u (an unformmated sequence of integers) and computes the MD5 sum. +<>= + module function md5sum_from_unit (u) result (digest) + integer, intent(in) :: u + character(len=32) :: digest + end function md5sum_from_unit <>= - function md5sum_from_unit (u) result (digest) + module function md5sum_from_unit (u) result (digest) integer, intent(in) :: u character(len=32) :: digest type(message_t) :: m character :: char integer :: iostat READ_CHARS: do read (u, "(A)", advance="no", iostat=iostat) char select case (iostat) case (0) call message_append_string (m, char) case (EOR) call message_append_string (m, LF) case (EOF) exit READ_CHARS case default call msg_fatal & ("Computing MD5 sum: I/O error while reading from scratch file") end select end do READ_CHARS call message_pad (m) call message_digest (m, digest) call message_clear (m) end function md5sum_from_unit @ %def md5sum_from_unit @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[md5_ut.f90]]>>= <> module md5_ut use unit_tests use md5_uti <> <> contains <> end module md5_ut @ %def md5_ut @ <<[[md5_uti.f90]]>>= <> module md5_uti use diagnostics use md5 <> <> contains <> end module md5_uti @ %def md5_ut @ API: driver for the unit tests below. <>= public :: md5_test <>= subroutine md5_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine md5_test @ %def md5_test @ This function checks the implementation by computing the checksum of certain strings and comparing them with the known values. <>= call test (md5_1, "md5_1", & "check MD5 sums", & u, results) <>= public :: md5_1 <>= subroutine md5_1 (u) integer, intent(in) :: u character(32) :: s integer, parameter :: n = 7 integer :: i character(80), dimension(n) :: teststring data teststring(1) /""/ data teststring(2) /"a"/ data teststring(3) /"abc"/ data teststring(4) /"message digest"/ data teststring(5) /"abcdefghijklmnopqrstuvwxyz"/ data teststring(6) /"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"/ data teststring(7) /"12345678901234567890123456789012345678901234567890123456789012345678901234567890"/ character(32), dimension(n) :: result data result(1) /"D41D8CD98F00B204E9800998ECF8427E"/ data result(2) /"0CC175B9C0F1B6A831C399E269772661"/ data result(3) /"900150983CD24FB0D6963F7D28E17F72"/ data result(4) /"F96B697D7CB7938D525A2F31AAF161D0"/ data result(5) /"C3FCD3D76192E4007DFB496CCA67E13B"/ data result(6) /"D174AB98D277D9F5A5611C2C9F419D9F"/ data result(7) /"57EDF4A22BE3C955AC49DA2E2107B67A"/ write (u, "(A)") "* Test output: MD5" write (u, "(A)") "* Purpose: test MD5 sums" write (u, "(A)") do i = 1, n write (u, "(A)") "MD5 test string = " // '"'// & trim (teststring(i)) // '"' s = md5sum (trim (teststring(i))) write (u, "(A)") "MD5 check sum = " // trim (s) write (u, "(A)") "Ref check sum = " // result(i) if (s == result(i)) then call msg_message ("=> ok", u) else call msg_message ("=> MD5 sum self-test failed", u) end if end do call msg_message ("=============================================================================|", unit=u) end subroutine md5_1 @ %def md5_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Permutations} Permute arrays of integers (of specific kind). <<[[permutations.f90]]>>= <> module permutations use kinds, only: TC <> <> <> <> + interface +<> + end interface + +end module permutations +@ %def permutations +@ +<<[[permutations_sub.f90]]>>= +<> + +submodule (permutations) permutations_s + +<> + contains <> -end module permutations -@ %def permutations +end submodule permutations_s + +@ %def permutations_s @ \subsection{Permutations} A permutation is an array of integers. Each integer between one and [[size]] should occur exactly once. <>= public :: permutation_t <>= type :: permutation_t private integer, dimension(:), allocatable :: p end type permutation_t @ %def permutation @ Initialize with the identity permutation. <>= public :: permutation_init public :: permutation_final +<>= + elemental module subroutine permutation_init (p, size) + type(permutation_t), intent(inout) :: p + integer, intent(in) :: size + end subroutine permutation_init + elemental module subroutine permutation_final (p) + type(permutation_t), intent(inout) :: p + end subroutine permutation_final <>= - elemental subroutine permutation_init (p, size) + elemental module subroutine permutation_init (p, size) type(permutation_t), intent(inout) :: p integer, intent(in) :: size integer :: i allocate (p%p (size)) forall (i = 1:size) p%p(i) = i end forall end subroutine permutation_init - elemental subroutine permutation_final (p) + elemental module subroutine permutation_final (p) type(permutation_t), intent(inout) :: p deallocate (p%p) end subroutine permutation_final @ %def permutation_init permutation_final @ I/O: <>= public :: permutation_write +<>= + module subroutine permutation_write (p, u) + type(permutation_t), intent (in) :: p + integer, intent(in) :: u + end subroutine permutation_write <>= - subroutine permutation_write (p, u) + module subroutine permutation_write (p, u) type(permutation_t), intent (in) :: p integer, intent(in) :: u integer :: i do i = 1, size (p%p) if (size (p%p) < 10) then write (u,"(1x,I1)", advance="no") p%p(i) else write (u,"(1x,I3)", advance="no") p%p(i) end if end do write (u, *) end subroutine permutation_write @ %def permutation_write @ Administration: <>= public :: permutation_size +<>= + elemental module function permutation_size (perm) result (s) + type(permutation_t), intent(in) :: perm + integer :: s + end function permutation_size <>= - elemental function permutation_size (perm) result (s) + elemental module function permutation_size (perm) result (s) type(permutation_t), intent(in) :: perm integer :: s s = size (perm%p) end function permutation_size @ %def permutation_size @ Extract an entry in a permutation. <>= public :: permute +<>= + elemental module function permute (i, p) result (j) + integer, intent(in) :: i + type(permutation_t), intent(in) :: p + integer :: j + end function permute <>= - elemental function permute (i, p) result (j) + elemental module function permute (i, p) result (j) integer, intent(in) :: i type(permutation_t), intent(in) :: p integer :: j if (i > 0 .and. i <= size (p%p)) then j = p%p(i) else j = 0 end if end function permute @ %def permute @ Check whether a permutation is valid: Each integer in the range occurs exactly once. <>= public :: permutation_ok +<>= + elemental module function permutation_ok (perm) result (ok) + type(permutation_t), intent(in) :: perm + logical :: ok + end function permutation_ok <>= - elemental function permutation_ok (perm) result (ok) + elemental module function permutation_ok (perm) result (ok) type(permutation_t), intent(in) :: perm logical :: ok integer :: i logical, dimension(:), allocatable :: set ok = .true. allocate (set (size (perm%p))) set = .false. do i = 1, size (perm%p) ok = (perm%p(i) > 0 .and. perm%p(i) <= size (perm%p)) if (.not.ok) return set(perm%p(i)) = .true. end do ok = all (set) end function permutation_ok @ %def permutation_ok @ Find the permutation that transforms the second array into the first one. We assume that this is possible and unique and all bounds are set correctly. This cannot be elemental. <>= public :: permutation_find +<>= + module subroutine permutation_find (perm, a1, a2) + type(permutation_t), intent(inout) :: perm + integer, dimension(:), intent(in) :: a1, a2 + end subroutine permutation_find <>= - subroutine permutation_find (perm, a1, a2) + module subroutine permutation_find (perm, a1, a2) type(permutation_t), intent(inout) :: perm integer, dimension(:), intent(in) :: a1, a2 integer :: i, j if (allocated (perm%p)) deallocate (perm%p) allocate (perm%p (size (a1))) do i = 1, size (a1) do j = 1, size (a2) if (a1(i) == a2(j)) then perm%p(i) = j exit end if perm%p(i) = 0 end do end do end subroutine permutation_find @ %def permutation_find @ Find all permutations that transform an array of integers into itself. The resulting permutation list is allocated with the correct length and filled. The first step is to count the number of different entries in [[code]]. Next, we scan [[code]] again and assign a mask to each different entry, true for all identical entries. Finally, we recursively permute the identity for each possible mask. The permutation is done as follows: A list of all permutations of the initial one with respect to the current mask is generated, then the permutations are generated in turn for each permutation in this list with the next mask. The result is always stored back into the main list, starting from the end of the current list. <>= public :: permutation_array_make +<>= + module subroutine permutation_array_make (pa, code) + type(permutation_t), dimension(:), allocatable, intent(out) :: pa + integer, dimension(:), intent(in) :: code + end subroutine permutation_array_make <>= - subroutine permutation_array_make (pa, code) + module subroutine permutation_array_make (pa, code) type(permutation_t), dimension(:), allocatable, intent(out) :: pa integer, dimension(:), intent(in) :: code logical, dimension(size(code)) :: mask logical, dimension(:,:), allocatable :: imask integer, dimension(:), allocatable :: n_i type(permutation_t) :: p_init type(permutation_t), dimension(:), allocatable :: p_tmp integer :: psize, i, j, k, n_different, n, nn_k psize = size (code) mask = .true. n_different = 0 do i=1, psize if (mask(i)) then n_different = n_different + 1 mask = mask .and. (code /= code(i)) end if end do allocate (imask(psize, n_different), n_i(n_different)) mask = .true. k = 0 do i=1, psize if (mask(i)) then k = k + 1 imask(:,k) = (code == code(i)) n_i(k) = factorial (count(imask(:,k))) mask = mask .and. (code /= code(i)) end if end do n = product (n_i) allocate (pa (n)) call permutation_init (p_init, psize) pa(1) = p_init nn_k = 1 do k = 1, n_different allocate (p_tmp (n_i(k))) do i = nn_k, 1, -1 call permutation_array_with_mask (p_tmp, imask(:,k), pa(i)) do j = n_i(k), 1, -1 pa((i-1)*n_i(k) + j) = p_tmp(j) end do end do deallocate (p_tmp) nn_k = nn_k * n_i(k) end do call permutation_final (p_init) deallocate (imask, n_i) end subroutine permutation_array_make @ %def permutation_array_make @ Make a list of permutations of the elements marked true in the [[mask]] array. The final permutation list must be allocated with the correct length ($n!$). The third argument is the initial permutation to start with, which must have the same length as the [[mask]] array (this is not checked). <>= subroutine permutation_array_with_mask (pa, mask, p_init) type(permutation_t), dimension(:), intent(inout) :: pa logical, dimension(:), intent(in) :: mask type(permutation_t), intent(in) :: p_init integer :: plen integer :: i, ii, j, fac_i, k, x integer, dimension(:), allocatable :: index plen = size (pa) allocate (index(count(mask))) ii = 0 do i = 1, size (mask) if (mask(i)) then ii = ii + 1 index(ii) = i end if end do pa = p_init ii = 0 fac_i = 1 do i = 1, size (mask) if (mask(i)) then ii = ii + 1 fac_i = fac_i * ii x = permute (i, p_init) do j = 1, plen k = ii - mod (((j-1)*fac_i)/plen, ii) call insert (pa(j), x, k, ii, index) end do end if end do deallocate (index) contains subroutine insert (p, x, k, n, index) type(permutation_t), intent(inout) :: p integer, intent(in) :: x, k, n integer, dimension(:), intent(in) :: index integer :: i do i = n, k+1, -1 p%p(index(i)) = p%p(index(i-1)) end do p%p(index(k)) = x end subroutine insert end subroutine permutation_array_with_mask @ %def permutation_array_with_mask @ The factorial function is needed for pre-determining the number of permutations that will be generated: <>= public :: factorial +<>= + elemental module function factorial (n) result (f) + integer, intent(in) :: n + integer :: f + end function factorial <>= - elemental function factorial (n) result (f) + elemental module function factorial (n) result (f) integer, intent(in) :: n integer :: f integer :: i f = 1 do i=2, abs(n) f = f*i end do end function factorial @ %def factorial @ \subsection{Operations on binary codes} Binary codes are needed for phase-space trees. Since the permutation function uses permutations, and no other special type is involved, we put the functions here. This is needed for phase space trees: permute bits in a tree binary code. If no permutation is given, leave as is. (We may want to access the permutation directly here if this is efficiency-critical.) <>= public :: tc_permute +<>= + module function tc_permute (k, perm, mask_in) result (pk) + integer(TC), intent(in) :: k, mask_in + type(permutation_t), intent(in) :: perm + integer(TC) :: pk + end function tc_permute <>= - function tc_permute (k, perm, mask_in) result (pk) + module function tc_permute (k, perm, mask_in) result (pk) integer(TC), intent(in) :: k, mask_in type(permutation_t), intent(in) :: perm integer(TC) :: pk integer :: i pk = iand (k, mask_in) do i = 1, size (perm%p) if (btest(k,i-1)) pk = ibset (pk, perm%p(i)-1) end do end function tc_permute @ %def tc_permute @ This routine returns the number of set bits in the tree code value [[k]]. Hence, it is the number of externals connected to the current line. If [[mask]] is present, the complement of the tree code is also considered, and the smaller number is returned. This gives the true distance from the external states, taking into account the initial particles. The complement number is increased by one, since for a scattering diagram the vertex with the sum of all final-state codes is still one point apart from the initial particles. <>= public :: tc_decay_level <>= interface tc_decay_level module procedure decay_level_simple module procedure decay_level_complement end interface @ %def decay_level +<>= + module function decay_level_complement (k, mask) result (l) + integer(TC), intent(in) :: k, mask + integer :: l + end function decay_level_complement + module function decay_level_simple (k) result(l) + integer(TC), intent(in) :: k + integer :: l + end function decay_level_simple <>= - function decay_level_complement (k, mask) result (l) + module function decay_level_complement (k, mask) result (l) integer(TC), intent(in) :: k, mask integer :: l l = min (decay_level_simple (k), & & decay_level_simple (ieor (k, mask)) + 1) end function decay_level_complement - function decay_level_simple (k) result(l) + module function decay_level_simple (k) result(l) integer(TC), intent(in) :: k integer :: l integer :: i l = 0 do i=0, bit_size(k)-1 if (btest(k,i)) l = l+1 end do end function decay_level_simple @ %def decay_level_simple decay_level_complement @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Sorting} This small module provides functions for sorting integer or real arrays. <<[[sorting.f90]]>>= <> module sorting <> use diagnostics <> <> <> contains <> end module sorting @ %def sorting @ \subsection{Implementation} The [[sort]] function returns, for a given integer or real array, the array sorted by increasing value. The current implementation is \emph{mergesort}, which has $O(n\ln n)$ behavior in all cases, and is stable for elements of equal value. The [[sort_abs]] variant sorts by increasing absolute value, where for identical absolute value, the positive number comes first. <>= public :: sort public :: sort_abs <>= interface sort module procedure sort_int module procedure sort_real end interface interface sort_abs module procedure sort_int_abs end interface @ %def sort sort_abs @ This variant of integer sort returns @ The body is identical, just the interface differs. <>= function sort_int (val_in) result (val) integer, dimension(:), intent(in) :: val_in integer, dimension(size(val_in)) :: val <> end function sort_int function sort_real (val_in) result (val) real(default), dimension(:), intent(in) :: val_in real(default), dimension(size(val_in)) :: val <> end function sort_real function sort_int_abs (val_in) result (val) integer, dimension(:), intent(in) :: val_in integer, dimension(size(val_in)) :: val <> end function sort_int_abs @ %def sort_int sort_real sort_int_abs <>= val = val_in( order (val_in) ) <>= val = val_in( order_abs (val_in) ) @ The [[order]] function returns, for a given integer or real array, the array of indices of the elements sorted by increasing value. <>= public :: order public :: order_abs <>= interface order module procedure order_int module procedure order_real end interface interface order_abs module procedure order_int_abs end interface @ %def order order_abs <>= function order_int (val) result (idx) integer, dimension(:), intent(in) :: val integer, dimension(size(val)) :: idx <> end function order_int function order_real (val) result (idx) real(default), dimension(:), intent(in) :: val integer, dimension(size(val)) :: idx <> end function order_real function order_int_abs (val) result (idx) integer, dimension(:), intent(in) :: val integer, dimension(size(val)) :: idx <> end function order_int_abs @ %def order_int order_real order_int_abs @ We start by individual elements, merge them to pairs, merge those to four-element subarrays, and so on. The last subarray can extend only up to the original array bound, of course, and the second of the subarrays to merge should contain at least one element. <>= <> call merge (idx(b1:e2), idx(b1:e1), idx(b2:e2), val) <> @ <>= <> call merge_abs (idx(b1:e2), idx(b1:e1), idx(b2:e2), val) <> @ <>= integer :: n, i, s, b1, b2, e1, e2 n = size (idx) do i = 1, n idx(i) = i end do s = 1 do while (s < n) do b1 = 1, n-s, 2*s b2 = b1 + s e1 = b2 - 1 e2 = min (e1 + s, n) @ <>= end do s = 2 * s end do @ The merging step does the actual sorting. We take two sorted array sections and merge them to a sorted result array. We are working on the indices, and comparing is done by taking the associated [[val]] which is real or integer. <>= interface merge module procedure merge_int module procedure merge_real end interface interface merge_abs module procedure merge_int_abs end interface @ %def merge merge_abs <>= subroutine merge_int (res, src1, src2, val) integer, dimension(:), intent(out) :: res integer, dimension(:), intent(in) :: src1, src2 integer, dimension(:), intent(in) :: val integer, dimension(size(res)) :: tmp <> end subroutine merge_int subroutine merge_real (res, src1, src2, val) integer, dimension(:), intent(out) :: res integer, dimension(:), intent(in) :: src1, src2 real(default), dimension(:), intent(in) :: val integer, dimension(size(res)) :: tmp <> end subroutine merge_real subroutine merge_int_abs (res, src1, src2, val) integer, dimension(:), intent(out) :: res integer, dimension(:), intent(in) :: src1, src2 integer, dimension(:), intent(in) :: val integer, dimension(size(res)) :: tmp <> end subroutine merge_int_abs @ %def merge_int merge_real merge_int_abs <>= <> if (val(src1(i1)) <= val(src2(i2))) then <> @ We keep the elements if the absolute values are strictly ordered. If they are equal in magnitude, we keep them if the larger value comes first, or if they are equal. <>= <> if (abs (val(src1(i1))) < abs (val(src2(i2))) .or. & (abs (val(src1(i1))) == abs (val(src2(i2))) .and. & val(src1(i1)) >= val(src2(i2)))) then <> @ <>= integer :: i1, i2, i i1 = 1 i2 = 1 do i = 1, size (tmp) @ <>= tmp(i) = src1(i1); i1 = i1 + 1 if (i1 > size (src1)) then tmp(i+1:) = src2(i2:) exit end if else tmp(i) = src2(i2); i2 = i2 + 1 if (i2 > size (src2)) then tmp(i+1:) = src1(i1:) exit end if end if end do res = tmp @ @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sorting_ut.f90]]>>= <> module sorting_ut use unit_tests use sorting_uti <> <> contains <> end module sorting_ut @ %def sorting_ut @ <<[[sorting_uti.f90]]>>= <> module sorting_uti <> use sorting <> <> contains <> end module sorting_uti @ %def sorting_ut @ API: driver for the unit tests below. <>= public :: sorting_test <>= subroutine sorting_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sorting_test @ %def sorting_test @ This checks whether the sorting routine works correctly. <>= call test (sorting_1, "sorting_1", & "check sorting routines", & u, results) <>= public :: sorting_1 <>= subroutine sorting_1 (u) integer, intent(in) :: u integer, parameter :: NMAX = 10 real(default), dimension(NMAX) :: rval integer, dimension(NMAX) :: ival real, dimension(NMAX,NMAX) :: harvest_r integer, dimension(NMAX,NMAX) :: harvest_i integer, dimension(NMAX,NMAX) :: harvest_a integer :: i, j harvest_r(:, 1) = [0.9976, 0., 0., 0., 0., 0., 0., 0., 0., 0.] harvest_r(:, 2) = [0.5668, 0.9659, 0., 0., 0., 0., 0., 0., 0., 0.] harvest_r(:, 3) = [0.7479, 0.3674, 0.4806, 0., 0., 0., 0., 0., 0., & 0.] harvest_r(:, 4) = [0.0738, 0.0054, 0.3471, 0.3422, 0., 0., 0., 0., & 0., 0.] harvest_r(:, 5) = [0.2180, 0.1332, 0.9005, 0.3868, 0.4455, 0., 0., & 0., 0., 0.] harvest_r(:, 6) = [0.6619, 0.0161, 0.6509, 0.6464, 0.3230, & 0.8557, 0., 0., 0., 0.] harvest_r(:, 7) = [0.4013, 0.2069, 0.9685, 0.5984, 0.6730, & 0.4569, 0.3300, 0., 0., 0.] harvest_r(:, 8) = [0.1004, 0.7555, 0.6057, 0.7190, 0.8973, & 0.6582, 0.1507, 0.6123, 0., 0.] harvest_r(:, 9) = [0.9787, 0.9991, 0.2568, 0.5509, 0.6590, & 0.5540, 0.9778, 0.9019, 0.6579, 0.] harvest_r(:,10) = [0.7289, 0.4025, 0.9286, 0.1478, 0.6745, & 0.7696, 0.3393, 0.1158, 0.6144, 0.8206] harvest_i(:, 1) = [18, 0, 0, 0, 0, 0, 0, 0, 0, 0] harvest_i(:, 2) = [14, 9, 0, 0, 0, 0, 0, 0, 0, 0] harvest_i(:, 3) = [ 7, 8,11, 0, 0, 0, 0, 0, 0, 0] harvest_i(:, 4) = [19,19,14,19, 0, 0, 0, 0, 0, 0] harvest_i(:, 5) = [ 1,14,15,18,14, 0, 0, 0, 0, 0] harvest_i(:, 6) = [16,11, 1, 9,11, 2, 0, 0, 0, 0] harvest_i(:, 7) = [11,10,17, 6,13,13,10, 0, 0, 0] harvest_i(:, 8) = [ 5, 1, 2,10, 7, 0,15,12, 0, 0] harvest_i(:, 9) = [15,19, 2, 6,11, 0, 2, 4, 2, 0] harvest_i(:,10) = [ 1, 4, 8, 4,11, 0, 8, 7,19,13] harvest_a(:, 1) = [-6, 0, 0, 0, 0, 0, 0, 0, 0, 0] harvest_a(:, 2) = [-8, -9, 0, 0, 0, 0, 0, 0, 0, 0] harvest_a(:, 3) = [ 4, -3, 3, 0, 0, 0, 0, 0, 0, 0] harvest_a(:, 4) = [-6, 6, 2, -2, 0, 0, 0, 0, 0, 0] harvest_a(:, 5) = [ 1, -2, 0, -6, 8, 0, 0, 0, 0, 0] harvest_a(:, 6) = [-2, -1, -8, -5, 8, -5, 0, 0, 0, 0] harvest_a(:, 7) = [-9, 0, -6, 2, 5, 3, 2, 0, 0, 0] harvest_a(:, 8) = [-5, -7, 6, 7, -3, 0, -7, 4, 0, 0] harvest_a(:, 9) = [ 5, 0, -1, -7, 5, 2, 7, -3, 3, 0] harvest_a(:,10) = [-9, 2, -6, 3, -9, 5, 5, 7, 5, -9] write (u, "(A)") "* Test output: Sorting" write (u, "(A)") "* Purpose: test sorting routines" write (u, "(A)") write (u, "(A)") "* Sorting real values:" do i = 1, NMAX write (u, "(A)") rval(:i) = harvest_r(:i,i) write (u, "(10(1x,F7.4))") rval(:i) rval(:i) = sort (rval(:i)) write (u, "(10(1x,F7.4))") rval(:i) do j = i, 2, -1 if (rval(j)-rval(j-1) < 0) & write (u, "(A)") "*** Sorting failure. ***" end do end do write (u, "(A)") write (u, "(A)") "* Sorting integer values:" do i = 1, NMAX write (u, "(A)") ival(:i) = harvest_i(:i,i) write (u, "(10(1x,I2))") ival(:i) ival(:i) = sort (ival(:i)) write (u, "(10(1x,I2))") ival(:i) do j = i, 2, -1 if (ival(j)-ival(j-1) < 0) & write (u, "(A)") "*** Sorting failure. ***" end do end do write (u, "(A)") write (u, "(A)") "* Sorting integer values by absolute value:" do i = 1, NMAX write (u, "(A)") ival(:i) = harvest_a(:i,i) write (u, "(10(1x,I2))") ival(:i) ival(:i) = sort_abs (ival(:i)) write (u, "(10(1x,I2))") ival(:i) do j = i, 2, -1 if (abs(ival(j))-abs(ival(j-1)) < 0 .or. & (abs(ival(j))==abs(ival(j-1))) .and. ival(j)>ival(j-1)) & write (u, "(A)") "*** Sorting failure. ***" end do end do write (u, "(A)") write (u, "(A)") "* Test output end: sorting_1" end subroutine sorting_1 @ %def sorting_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Grids} \emph{This is not really a combinatorics module but this directory is the closest I could find. Maybe this will be moved to a seperate directory or combined with related stuff.} <<[[grids.f90]]>>= <> module grids <> use constants, only: zero, one, tiny_07 use io_units use format_defs, only: FMT_16 use diagnostics <> <> <> <> <> contains <> end module grids @ %def grids @ Grids are used in many applications and a general implementation seems useful. The relevant properties implemented so far are \begin{itemize} \item Segments of the hypercube are represented by an integer array with size $d$ corresponding to the dimension. \item There is a mapping from the indices to the location in the continuous memory block of values. \item Given a point in the hypercube, find the corresponding segment and the value of the grid therein. \item Update the grid sequentially to represent the maximum of a function over the unit hypercube. \item The grid can be saved to and recovered from disk. \end{itemize} The following might be implemented in the future \begin{itemize} \item Generate a random point in the hypercube by interpreting the grid as probability distribution. \emph{This would most likely be solved by using projections and the [[selector_t]], which would make a move of this module higher up in the dependency tree necessary.} \item Update the grid sequentially to represent the \emph{minimum} of a function over the unit hypercube. \end{itemize} <>= public :: grid_t <>= type :: grid_t private real(default), dimension(:), allocatable :: values integer, dimension(:), allocatable :: points contains <> end type grid_t @ %def grid_t @ \subsection{Initializer and finalizer} For initialization, we expect the number of points for each dimension as an array or the the number of dimensions as a scalar whereby the default number of points is used then for each dimension. <>= generic :: init => init_base, init_simple procedure :: init_base => grid_init_base procedure :: init_simple => grid_init_simple <>= pure subroutine grid_init_base (grid, points) class(grid_t), intent(inout) :: grid integer, dimension(:), intent(in) :: points allocate (grid%points (size (points))) allocate (grid%values (product (points))) grid%points = points grid%values = zero end subroutine grid_init_base @ %def grid_init_base <>= pure subroutine grid_init_simple (grid, dimensions) class(grid_t), intent(inout) :: grid integer, intent(in) :: dimensions allocate (grid%points (dimensions)) allocate (grid%values (DEFAULT_POINTS_PER_DIMENSION ** dimensions)) grid%points = DEFAULT_POINTS_PER_DIMENSION grid%values = zero end subroutine grid_init_simple @ %def grid_init_simple @ Manual assignment (tests) <>= procedure :: set_values => grid_set_values <>= subroutine grid_set_values (grid, values) class(grid_t), intent(inout) :: grid real(default), dimension(:), intent(in) :: values grid%values = values end subroutine grid_set_values @ %def grid_set_values @ A reasonable default <>= integer, parameter :: DEFAULT_POINTS_PER_DIMENSION = 100 @ %def DEFAULT_POINTS_PER_DIMENSION @ Calling this is not mandatory, when an instance of [[grid_t]] goes out of scope as it will be done by Fortran automatically. <>= procedure :: final => grid_final <>= pure subroutine grid_final (grid) class(grid_t), intent(inout) :: grid if (allocated (grid%values)) then deallocate (grid%values) end if if (allocated (grid%points)) then deallocate (grid%points) end if end subroutine grid_final @ %def grid_final @ \subsection{Segment finding and memory mapping} The [[indices]] array is expected to go from 1 to $d$ whereby the entries for the different $\text{dim}$s are from 1 to $n_\text{points}(\text{dim})$. @ We get the value of the grid either from given [[indices]] or from a point [[x]] in the hypercube. In the latter case, we have to find the segment first. <>= generic :: get_value => get_value_from_x, get_value_from_indices procedure :: get_value_from_x => grid_get_value_from_x procedure :: get_value_from_indices => grid_get_value_from_indices <>= function grid_get_value_from_indices (grid, indices) real(default) :: grid_get_value_from_indices class(grid_t), intent(in) :: grid integer, dimension(:), intent(in) :: indices grid_get_value_from_indices = grid%values(grid%get_index(indices)) end function grid_get_value_from_indices @ %def grid_get_value_from_indices <>= function grid_get_value_from_x (grid, x) real(default) :: grid_get_value_from_x class(grid_t), intent(in) :: grid real(default), dimension(:), intent(in) :: x grid_get_value_from_x = grid_get_value_from_indices & (grid, grid_get_segment (grid, x)) end function grid_get_value_from_x @ %def grid_get_value_from_x @ The segment is the part of the grid that contains the point [[x]] and is identified by a tupel of [[indices]]. This is just a brute force search, for fine grids one could also implement a binary search for $\mathcal{O}(\log{N})$ behavior instead of $\mathcal{O}({N})$. <>= procedure :: get_segment => grid_get_segment <>= function grid_get_segment (grid, x, unit) class(grid_t), intent(in) :: grid real(default), dimension(:), intent(in) :: x integer, intent(in), optional :: unit integer, dimension(1:size (x)) :: grid_get_segment integer :: dim, i real(default) :: segment_width grid_get_segment = 0 do dim = 1, size (grid%points) segment_width = one / grid%points (dim) SEARCH: do i = 1, grid%points (dim) if (x (dim) <= i * segment_width + tiny_07) then grid_get_segment (dim) = i exit SEARCH end if end do SEARCH if (grid_get_segment (dim) == 0) then do i = 1, size(x) write (msg_buffer, "(A," // DEFAULT_OUTPUT_PRECISION // ")") & "x[i] = ", x(i) call msg_message () end do call msg_error ("grid_get_segment: Did not find x in [0,1]^d", & unit=unit) end if end do end function grid_get_segment @ %def grid_get_segment @ This is a simple storage mapping function but more sophisticated ideas like hashing could be implemented. \begin{align} \text{index} = &\text{indices}(1) + \notag\\ &\text{indices}(2) * \text{size}(1) + \notag\\ &\text{indices}(3) * \text{size}(1) * \text{size}(2) + \dots \end{align} <>= procedure :: get_index => grid_get_index <>= pure function grid_get_index (grid, indices) result (grid_index) integer :: grid_index class(grid_t), intent(in) :: grid integer, dimension(:), intent(in) :: indices integer :: dim_innerloop, dim_outerloop, multiplier grid_index = 1 do dim_outerloop = 1, size(indices) multiplier = 1 do dim_innerloop = 1, dim_outerloop - 1 multiplier = multiplier * grid%points (dim_innerloop) end do grid_index = grid_index + (indices(dim_outerloop) - 1) * multiplier end do end function grid_get_index @ %def grid_get_index @ \subsection{Grid manipulations} Given a point in the hypercube [[x]] and its value [[y]], we update the grids, such that the stepwise function $f$ defined by the grid is $f(x_i)\geq y_i\;\forall \{x_i, y_i\}$. <>= procedure :: update_maxima => grid_update_maxima <>= subroutine grid_update_maxima (grid, x, y) class(grid_t), intent(inout) :: grid real(default), dimension(:), intent(in) :: x real(default), intent(in) :: y integer, dimension(1:size(x)) :: indices indices = grid%get_segment (x) if (grid%get_value (indices) < y) then grid%values (grid%get_index (indices)) = y end if end subroutine grid_update_maxima @ %def grid_update_maxima @ More general cases have to be thought through when they are needed. \emph{This is inefficient and non-general}. <>= procedure :: get_maximum_in_3d => grid_get_maximum_in_3d <>= function grid_get_maximum_in_3d (grid, projected_index) result (maximum) real(default) :: maximum class(grid_t), intent(in) :: grid integer, intent(in) :: projected_index real(default) :: val integer :: i, j maximum = zero do i = 1, grid%points(1) do j = 1, grid%points(2) val = grid%get_value ([i, j, projected_index]) if (val > maximum) then maximum = val end if end do end do end function grid_get_maximum_in_3d @ %def grid_get_maximum_in_3d @ <>= procedure :: is_non_zero_everywhere => grid_is_non_zero_everywhere <>= pure function grid_is_non_zero_everywhere (grid) result (yorn) logical :: yorn class(grid_t), intent(in) :: grid yorn = all (abs (grid%values) > zero) end function grid_is_non_zero_everywhere @ %def grid_is_non_zero_everywhere @ Returns true if any value of the grid is non-zero. We need this to determine whether the grid has been filled during integration. <>= procedure :: has_non_zero_entries => grid_has_non_zero_entries <>= pure function grid_has_non_zero_entries (grid) result (non_zero) logical :: non_zero class(grid_t), intent(in) :: grid non_zero = any (abs (grid%values) > zero) end function grid_has_non_zero_entries @ %def grid_has_non_zero_entries @ MPI: We allow for several grids in a parallelized run to be combined with [[MPI_reduce]]. The operator has to be specified. We do not check on any specifications. <>= procedure :: mpi_reduce => grid_mpi_reduce <>= subroutine grid_mpi_reduce (grid, operator) class(grid_t), intent(inout) :: grid type(MPI_op), intent(in) :: operator real(default), dimension(size (grid%values)) :: root_values integer :: rank call MPI_Comm_rank (MPI_COMM_WORLD, rank) call MPI_Reduce (grid%values, root_values, size (grid%values),& & MPI_DOUBLE_PRECISION, operator, 0, MPI_COMM_WORLD) if (rank == 0) then grid%values = root_values end if end subroutine grid_mpi_reduce @ %def grid_mpi_reduce \subsection{Input and Output to screen and disk} <>= procedure :: write => grid_write <>= subroutine grid_write (grid, unit) class(grid_t), intent(in) :: grid integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1X,A)") "Grid" write (u, "(2X,A,2X)", advance='no') "Number of points per dimension:" if (allocated (grid%points)) then do i = 1, size (grid%points) write (u, "(I12,1X)", advance='no') & grid%points (i) end do end if write (u, *) write (u, "(2X,A)") "Values of the grid:" if (allocated (grid%values)) then do i = 1, size (grid%values) write (u, "(" // DEFAULT_OUTPUT_PRECISION // ",1X)") & grid%values (i) end do end if call grid%compute_and_write_mean_and_max (u) end subroutine grid_write @ %def grid_write @ <>= procedure :: compute_and_write_mean_and_max => & grid_compute_and_write_mean_and_max <>= subroutine grid_compute_and_write_mean_and_max (grid, unit) class(grid_t), intent(in) :: grid integer, intent(in), optional :: unit integer :: u, i, n_values real(default) :: mean, val, maximum u = given_output_unit (unit); if (u < 0) return mean = zero maximum = zero if (allocated (grid%values)) then n_values = size (grid%values) do i = 1, n_values val = grid%values (i) mean = mean + val / n_values if (val > maximum) then maximum = val end if end do write (msg_buffer, "(A," // DEFAULT_OUTPUT_PRECISION // ")") & "Grid: Mean value of the grid: ", mean call msg_message () write (msg_buffer, "(A," // DEFAULT_OUTPUT_PRECISION // ")") & "Grid: Max value of the grid: ", maximum call msg_message () if (maximum > zero) then write (msg_buffer, "(A," // DEFAULT_OUTPUT_PRECISION // ")") & "Grid: Mean/Max value of the grid: ", mean / maximum call msg_message () end if else call msg_warning ("Grid: Grid is not allocated!") end if end subroutine grid_compute_and_write_mean_and_max @ %def grid_compute_and_write_mean_and_max @ <>= procedure :: save_to_file => grid_save_to_file <>= subroutine grid_save_to_file (grid, file) class(grid_t), intent(in) :: grid character(len=*), intent(in) :: file integer :: iostat, u, i u = free_unit () open (file=file, unit=u, action='write') if (allocated (grid%points)) then write (u, "(I12)") size (grid%points) do i = 1, size (grid%points) write (u, "(I12,1X)", advance='no', iostat=iostat) & grid%points (i) end do end if write (u, *) if (allocated (grid%values)) then do i = 1, size (grid%values) write (u, "(" // DEFAULT_OUTPUT_PRECISION // ",1X)", & advance='no', iostat=iostat) grid%values (i) end do end if if (iostat /= 0) then call msg_warning & ('grid_save_to_file: Could not save grid to file') end if close (u) end subroutine grid_save_to_file @ %def grid_save_to_file @ <>= character(len=*), parameter :: DEFAULT_OUTPUT_PRECISION = FMT_16 @ %def DEFAULT_OUTPUT_PRECISION @ <>= public :: verify_points_for_grid <>= function verify_points_for_grid (file, points) result (valid) logical :: valid character(len=*), intent(in) :: file integer, dimension(:), intent(in) :: points integer, dimension(:), allocatable :: points_from_file integer :: u call load_points_from_file (file, u, points_from_file) close (u) if (allocated (points_from_file)) then valid = all (points == points_from_file) else valid = .false. end if end function verify_points_for_grid @ %def verify_points_for_grid @ Returns the [[unit]] that has opened the input [[file]] and read the first two lines. The caller has to close it. Furthermore, we return [[points]] containing the number of points in each dimension. <>= subroutine load_points_from_file (file, unit, points) character(len=*), intent(in) :: file integer, intent(out) :: unit integer, dimension(:), allocatable :: points integer :: iostat, n_dimensions, i_dim unit = free_unit () open (file=file, unit=unit, action='read', iostat=iostat) if (iostat /= 0) return read (unit, "(I12)", iostat=iostat) n_dimensions if (iostat /= 0) return allocate (points (n_dimensions)) do i_dim = 1, size (points) read (unit, "(I12,1X)", advance='no', iostat=iostat) & points (i_dim) end do if (iostat /= 0) return read (unit, *) if (iostat /= 0) return end subroutine load_points_from_file @ %def procedure @ <>= procedure :: load_from_file => grid_load_from_file <>= subroutine grid_load_from_file (grid, file) class(grid_t), intent(out) :: grid character(len=*), intent(in) :: file integer :: iostat, u, i integer, dimension(:), allocatable :: points call load_points_from_file (file, u, points) if (.not. allocated (points)) return call grid%init (points) do i = 1, size (grid%values) read (u, "(" // DEFAULT_OUTPUT_PRECISION // ",1X)", advance='no', iostat=iostat) & grid%values (i) end do if (iostat /= 0) then call msg_warning ('grid_load_from_file: Could not load grid from file') end if close (u) end subroutine grid_load_from_file @ %def grid_load_from_file @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[grids_ut.f90]]>>= <> module grids_ut use unit_tests use grids_uti <> <> contains <> end module grids_ut @ %def grids_ut @ <<[[grids_uti.f90]]>>= <> module grids_uti <> use constants, only: zero, one, two, three, four, tiny_07 use file_utils, only: delete_file use numeric_utils use grids <> <> contains <> end module grids_uti @ %def grids_ut @ API: driver for the unit tests below. <>= public :: grids_test <>= subroutine grids_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine grids_test @ %def grids_test @ \subsubsection{Test Index Function} <>= call test(grids_1, "grids_1", & "Test Index Function", u, results) <>= public :: grids_1 <>= subroutine grids_1 (u) integer, intent(in) :: u type(grid_t) :: grid write (u, "(A)") "* Test output: grids_1" write (u, "(A)") "* Purpose: Test Index Function" write (u, "(A)") call grid%init ([3]) call grid%write(u) call assert (u, grid%get_index([1]) == 1, "grid%get_index(1) == 1") call assert (u, grid%get_index([2]) == 2, "grid%get_index(2) == 2") call assert (u, grid%get_index([3]) == 3, "grid%get_index(3) == 3") call grid%final () call grid%init ([3,3]) call grid%write(u) call assert (u, grid%get_index([1,1]) == 1, "grid%get_index(1,1) == 1") call assert (u, grid%get_index([2,1]) == 2, "grid%get_index(2,1) == 2") call assert (u, grid%get_index([3,1]) == 3, "grid%get_index(3,1) == 3") call assert (u, grid%get_index([1,2]) == 4, "grid%get_index(1,2) == 4") call assert (u, grid%get_index([2,2]) == 5, "grid%get_index(2,2) == 5") call assert (u, grid%get_index([3,2]) == 6, "grid%get_index(3,2) == 6") call assert (u, grid%get_index([1,3]) == 7, "grid%get_index(1,3) == 7") call assert (u, grid%get_index([2,3]) == 8, "grid%get_index(2,3) == 8") call assert (u, grid%get_index([3,3]) == 9, "grid%get_index(3,3) == 9") call grid%final () call grid%init ([3,3,2]) call grid%write(u) call assert (u, grid%get_index([1,1,1]) == 1, "grid%get_index(1,1,1) == 1") call assert (u, grid%get_index([2,1,2]) == 2+9, "grid%get_index(2,1,2) == 2+9") call assert (u, grid%get_index([3,3,1]) == 9, "grid%get_index(3,3,1) == 3") call assert (u, grid%get_index([3,1,2]) == 3+9, "grid%get_index(3,1,2) == 4+9") call assert (u, grid%get_index([2,2,1]) == 5, "grid%get_index(2,2,1) == 5") call assert (u, grid%get_index([3,2,2]) == 6+9, "grid%get_index(3,2,2) == 6+9") call assert (u, grid%get_index([1,3,1]) == 7, "grid%get_index(1,3,1) == 7") call assert (u, grid%get_index([2,3,2]) == 8+9, "grid%get_index(2,3,2) == 8+9") call assert (u, grid%get_index([3,3,2]) == 9+9, "grid%get_index(3,3,2) == 9+9") call grid%final () write (u, "(A)") write (u, "(A)") "* Test output end: grids_1" end subroutine grids_1 @ %def grids_1 @ \subsubsection{Saving and Loading} <>= call test(grids_2, "grids_2", & "Saving and Loading", u, results) <>= public :: grids_2 <>= subroutine grids_2 (u) integer, intent(in) :: u type(grid_t) :: grid write (u, "(A)") "* Test output: grids_2" write (u, "(A)") "* Purpose: Saving and Loading" write (u, "(A)") call grid%init ([3]) call grid%set_values ([one, two, three]) call grid%save_to_file ('grids_2_test') call grid%final () call assert (u, verify_points_for_grid('grids_2_test', [3]), & "verify_points_for_grid") call grid%load_from_file ('grids_2_test') call grid%write (u) call assert (u, nearly_equal (grid%get_value([1]), one), "grid%get_value(1) == 1") call assert (u, nearly_equal (grid%get_value([2]), two), "grid%get_value(2) == 2") call assert (u, nearly_equal (grid%get_value([3]), three), "grid%get_value(3) == 3") call grid%final () call grid%init ([3,3]) call grid%set_values ([one, two, three, four, zero, zero, zero, zero, zero]) call grid%save_to_file ('grids_2_test') call grid%final () call assert (u, verify_points_for_grid('grids_2_test', [3,3]), & "verify_points_for_grid") call grid%load_from_file ('grids_2_test') call grid%write (u) call assert (u, nearly_equal (grid%get_value([1,1]), one), "grid%get_value(1,1) == 1") call assert (u, nearly_equal (grid%get_value([2,1]), two), "grid%get_value(2,1) == 2") call assert (u, nearly_equal (grid%get_value([3,1]), three), "grid%get_value(3,1) == 3") call assert (u, nearly_equal (grid%get_value([1,2]), four), "grid%get_value(1,2) == 4") call delete_file ('grids_2_test') call grid%load_from_file ('grids_2_test') call assert (u, .not. verify_points_for_grid('grids_2_test', [3,3]), & "verify_points_for_grid") call grid%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: grids_2" end subroutine grids_2 @ %def grids_2 @ \subsubsection{Get Segments} <>= call test(grids_3, "grids_3", & "Get Segments", u, results) <>= public :: grids_3 <>= subroutine grids_3 (u) integer, intent(in) :: u type(grid_t) :: grid integer, dimension(2) :: fail write (u, "(A)") "* Test output: grids_3" write (u, "(A)") "* Purpose: Get Segments" write (u, "(A)") call grid%init ([3]) call assert (u, all(grid%get_segment([0.00_default]) == [1]), & "all(grid%get_segment([0.00_default]) == [1])") call assert (u, all(grid%get_segment([0.32_default]) == [1]), & "all(grid%get_segment([0.32_default]) == [1])") call assert (u, all(grid%get_segment([0.52_default]) == [2]), & "all(grid%get_segment([0.52_default]) == [2])") call assert (u, all(grid%get_segment([1.00_default]) == [3]), & "all(grid%get_segment([1.00_default]) == [3])") call grid%final () call grid%init ([3,3]) call assert (u, all(grid%get_segment([0.00_default,0.00_default]) == [1,1]), & "all(grid%get_segment([0.00_default,0.00_default]) == [1,1])") call assert (u, all(grid%get_segment([0.32_default,0.32_default]) == [1,1]), & "all(grid%get_segment([0.32_default,0.32_default]) == [1,1])") call assert (u, all(grid%get_segment([0.52_default,0.52_default]) == [2,2]), & "all(grid%get_segment([0.52_default,0.52_default]) == [2,2])") call assert (u, all(grid%get_segment([1.00_default,1.00_default]) == [3,3]), & "all(grid%get_segment([1.00_default,1.00_default]) == [3,3])") write (u, "(A)") "* A double error is expected" fail = grid%get_segment([1.10_default,1.10_default], u) call grid%final () write (u, "(A)") write (u, "(A)") "* Test output end: grids_3" end subroutine grids_3 @ %def grids_3 @ \subsubsection{Update Maxima} <>= call test(grids_4, "grids_4", & "Update Maxima", u, results) <>= public :: grids_4 <>= subroutine grids_4 (u) integer, intent(in) :: u type(grid_t) :: grid write (u, "(A)") "* Test output: grids_4" write (u, "(A)") "* Purpose: Update Maxima" write (u, "(A)") call grid%init ([4,4]) call grid%update_maxima ([0.1_default, 0.0_default], 0.3_default) call grid%update_maxima ([0.9_default, 0.95_default], 1.7_default) call grid%write (u) call assert_equal (u, grid%get_value([1,1]), 0.3_default, & "grid%get_value([1,1]") call assert_equal (u, grid%get_value([2,2]), 0.0_default, & "grid%get_value([2,2]") call assert_equal (u, grid%get_value([4,4]), 1.7_default, & "grid%get_value([4,4]") write (u, "(A)") write (u, "(A)") "* Test output end: grids_4" end subroutine grids_4 @ %def grids_4 @ \subsubsection{Finding and checking} <>= call test(grids_5, "grids_5", & "Finding and checking", u, results) <>= public :: grids_5 <>= subroutine grids_5 (u) integer, intent(in) :: u type(grid_t) :: grid real(default) :: first, second write (u, "(A)") "* Test output: grids_5" write (u, "(A)") "* Purpose: Finding and checking" write (u, "(A)") call grid%init ([2,2,2]) first = one / two - tiny_07 second = two / two - tiny_07 call grid%update_maxima ([0.1_default, 0.0_default, first], 0.3_default) call grid%update_maxima ([0.9_default, 0.95_default, second], 1.7_default) call grid%write (u) call assert (u, .not. grid%is_non_zero_everywhere (), & ".not. grid%is_non_zero_everywhere (") call assert_equal (u, grid%get_maximum_in_3d (1), 0.3_default, & "grid%get_maximum_in_3d (1)") call assert_equal (u, grid%get_maximum_in_3d (2), 1.7_default, & "grid%get_maximum_in_3d (2)") call grid%update_maxima ([0.9_default, 0.95_default, first], 1.8_default) call grid%update_maxima ([0.1_default, 0.95_default, first], 1.5_default) call grid%update_maxima ([0.9_default, 0.15_default, first], 1.5_default) call grid%update_maxima ([0.1_default, 0.0_default, second], 0.2_default) call grid%update_maxima ([0.1_default, 0.9_default, second], 0.2_default) call grid%update_maxima ([0.9_default, 0.0_default, second], 0.2_default) call grid%write (u) call assert (u, grid%is_non_zero_everywhere (), & "grid%is_non_zero_everywhere (") call assert_equal (u, grid%get_maximum_in_3d (1), 1.8_default, & "grid%get_maximum_in_3d (1)") call assert_equal (u, grid%get_maximum_in_3d (2), 1.7_default, & "grid%get_maximum_in_3d (2)") write (u, "(A)") write (u, "(A)") "* Test output end: grids_5" end subroutine grids_5 @ %def grids_5 @ One could think of multiple implementations of a generic type. <<[[solver.f90]]>>= <> module solver <> use constants, only: tiny_10 use numeric_utils use diagnostics <> <> <> <> <> contains <> end module solver @ %def solver @ <>= public :: solver_function_t <>= type, abstract :: solver_function_t contains procedure(solver_function_evaluate), deferred :: evaluate end type solver_function_t @ %def solver_function_t @ <>= abstract interface function solver_function_evaluate (solver_f, x) result (f) import complex(default) :: f class(solver_function_t), intent(in) :: solver_f real(default), intent(in) :: x end function end interface @ %def solver_function_evaluate @ <>= public :: solve_secant <>= function solve_secant (func, lower_start, upper_start, success, precision) result (x0) class(solver_function_t), intent(in) :: func real(default) :: x0 real(default), intent(in) :: lower_start, upper_start real(default), intent(in), optional :: precision logical, intent(out) :: success real(default) :: desired, x_curr, x_next, f_curr, f_next, x_new integer :: n_iter desired = DEFAULT_PRECISION; if (present(precision)) desired = precision x_curr = lower_start x_next = upper_start n_iter = 0 success = .false. SEARCH: do n_iter = n_iter + 1 f_curr = real( func%evaluate (x_curr) ) f_next = real( func%evaluate (x_next) ) <> x_new = x_next - (x_next - x_curr) / (f_next - f_curr) * f_next x_curr = x_next x_next = x_new end do SEARCH if (x0 < lower_start .or. x0 > upper_start) then call msg_warning ("solve: The root of the function is not in boundaries") return end if success = .true. end function solve_secant @ %def solve_secant <>= if (abs (f_next) < desired) then x0 = x_next exit end if if (n_iter > MAX_TRIES) then call msg_warning ("solve: Couldn't find root of function") return end if if (vanishes (f_next - f_curr)) then x_next = x_next + (x_next - x_curr) / 10 cycle end if @ @ Implements the bisection root-finding method to find a root of [[func]] between [[lower_start]] and [[upper_start]] with tolerance [[precision]]. <>= public :: solve_interval <>= function solve_interval (func, lower_start, upper_start, success, precision) & result (x0) class(solver_function_t), intent(in) :: func real(default) :: x0 real(default), intent(in) :: lower_start, upper_start real(default), intent(in), optional :: precision logical, intent(out) :: success real(default) :: desired real(default) :: x_low, x_high, x_half real(default) :: f_low, f_high, f_half integer :: n_iter success = .false. desired = DEFAULT_PRECISION; if (present(precision)) desired = precision x0 = lower_start x_low = lower_start x_high = upper_start f_low = real( func%evaluate (x_low) ) f_high = real( func%evaluate (x_high) ) if (f_low * f_high > 0) return if (x_low > x_high) then call display_solver_status() call msg_fatal ("Interval solver: Upper bound must be & &greater than lower bound") end if n_iter = 0 do n_iter = 1, MAX_TRIES x_half = (x_high + x_low)/2 f_half = real( func%evaluate (x_half) ) if (abs (f_half) <= desired) then x0 = x_half exit end if if (f_low * f_half > 0._default) then x_low = x_half f_low = f_half else x_high = x_half f_high = f_half end if end do if (x0 < lower_start .or. x0 > upper_start) then call msg_warning ("Interval solver: The root of the function& & is out of boundaries") return end if success = .true. contains subroutine display_solver_status () print *, '=================' print *, 'Status of interval solver: ' print *, 'initial values: ', lower_start, upper_start print *, 'iteration: ', n_iter print *, 'x_low: ', x_low, 'f_low: ', f_low print *, 'x_high: ', x_high, 'f_high: ', f_high print *, 'x_half: ', x_half, 'f_half: ', f_half end subroutine display_solver_status end function solve_interval @ %def solve_interval @ <>= public :: solve_qgaus <>= function solve_qgaus (integrand, grid) result (integral) class(solver_function_t), intent(in) :: integrand complex(default) :: integral real(default), dimension(:), intent(in) :: grid integer :: i, j real(default) :: xm, xr real(default), dimension(5) :: dx, & w = (/ 0.2955242247_default, 0.2692667193_default, & 0.2190863625_default, 0.1494513491_default, 0.0666713443_default /), & x = (/ 0.1488743389_default, 0.4333953941_default, 0.6794095682_default, & 0.8650633666_default, 0.9739065285_default /) integral = 0.0_default if ( size(grid) < 2 ) then call msg_warning ("solve_qgaus: size of integration grid smaller than 2.") return end if do i=1, size(grid)-1 xm = 0.5_default * ( grid(i+1) + grid(i) ) xr = 0.5_default * ( grid(i+1) - grid(i) ) do j=1, 5 dx(j) = xr * x(j) integral = integral + xr * w(j) * & ( integrand%evaluate (xm+dx(j)) + integrand%evaluate (xm-dx(j)) ) end do end do end function solve_qgaus @ %def solve_qgaus @ <>= real(default), parameter, public :: DEFAULT_PRECISION = tiny_10 @ %def name @ <>= integer, parameter :: MAX_TRIES = 10000 @ %def MAX_TRIES @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[solver_ut.f90]]>>= <> module solver_ut use unit_tests use solver_uti <> <> contains <> end module solver_ut @ %def solver_ut @ <<[[solver_uti.f90]]>>= <> module solver_uti <> use constants, only: zero, one, two use numeric_utils use solver <> <> <> contains <> <> end module solver_uti @ %def solver_ut @ API: driver for the unit tests below. <>= public :: solver_test <>= subroutine solver_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine solver_test @ %def solver_test @ \subsubsection{Test functions} <>= type, extends (solver_function_t) :: test_function_1_t contains procedure :: evaluate => test_func_1 end type test_function_1_t @ %def test_function_1_t @ <>= type, extends (solver_function_t) :: test_function_2_t contains procedure :: evaluate => test_func_2 end type test_function_2_t @ %def test_function_2_t @ <>= type, extends (solver_function_t) :: test_function_3_t contains procedure :: evaluate => test_func_3 end type test_function_3_t @ %def test_function_3_t @ <>= type, extends (solver_function_t) :: test_function_4_t contains procedure :: evaluate => test_func_4 end type test_function_4_t @ %def test_function_4_t @ <>= function test_func_1 (solver_f, x) result (f) complex(default) :: f class(test_function_1_t), intent(in) :: solver_f real(default), intent(in) :: x f = x end function test_func_1 function test_func_2 (solver_f, x) result (f) complex(default) :: f class(test_function_2_t), intent(in) :: solver_f real(default), intent(in) :: x f = x ** 2 end function test_func_2 function test_func_3 (solver_f, x) result (f) complex(default) :: f class(test_function_3_t), intent(in) :: solver_f real(default), intent(in) :: x f = x ** 3 end function test_func_3 function test_func_4 (solver_f, x) result (f) complex(default) :: f class(test_function_4_t), intent(in) :: solver_f real(default), intent(in) :: x real(default) :: s, cutoff s = 100.0_default cutoff = 1.01_default if (x < cutoff) then f = - (log (s) * log (log (s) / log(cutoff**2)) - log (s / cutoff**2)) - & log (one/two) else f = - (log (s) * log (log (s) / log(x**2)) - log (s / x**2)) - & log (one/two) end if end function test_func_4 @ %def test_func_1 @ \subsubsection{Solve trivial functions} <>= call test(solver_1, "solver_1", & "Solve trivial functions", u, results) <>= public :: solver_1 <>= subroutine solver_1 (u) integer, intent(in) :: u real(default) :: zero_position logical :: success type(test_function_1_t) :: test_func_1 type(test_function_2_t) :: test_func_2 type(test_function_3_t) :: test_func_3 type(test_function_4_t) :: test_func_4 write (u, "(A)") "* Test output: solver_1" write (u, "(A)") "* Purpose: Solve trivial functions" write (u, "(A)") zero_position = solve_interval (test_func_1, -one, one, success) call assert (u, success, "success") call assert_equal (u, zero_position, zero, "test_func_1: zero_position") zero_position = solve_interval (test_func_4, two, 10.0_default, success) call assert (u, success, "success") call assert_equal (u, zero_position, & 3.5216674011865940283397224_default, & "test_func_4: zero_position", rel_smallness=1000*DEFAULT_PRECISION) write (u, "(A)") write (u, "(A)") "* Test output end: solver_1" end subroutine solver_1 @ %def solver_1 @ Index: trunk/src/combinatorics/Makefile.am =================================================================== --- trunk/src/combinatorics/Makefile.am (revision 8771) +++ trunk/src/combinatorics/Makefile.am (revision 8772) @@ -1,233 +1,252 @@ ## Makefile.am -- Makefile for WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2021 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## The files in this directory implement standard algorithms for WHIZARD ## We create a library which is still to be combined with auxiliary libs. noinst_LTLIBRARIES = libcombinatorics.la check_LTLIBRARIES = libcombinatorics_ut.la COMMON_F90 = \ bytes.f90 \ hashes.f90 \ md5.f90 \ permutations.f90 \ sorting.f90 \ solver.f90 MPI_F90 = \ grids.f90_mpi SERIAL_F90 = \ grids.f90_serial +COMBINATORICS_SUBMODULES = \ + bytes_sub.f90 \ + hashes_sub.f90 \ + md5_sub.f90 \ + permutations_sub.f90 + +COMBINATORICS_MODULES = \ + $(COMMON_F90) \ + grids.f90 EXTRA_DIST = \ $(COMMON_F90) \ + $(COMBINATORICS_SUBMODULES) \ $(SERIAL_F90) \ $(MPI_F90) nodist_libcombinatorics_la_SOURCES = \ - $(COMMON_F90) \ - grids.f90 + $(COMBINATORICS_MODULES) \ + $(COMBINATORICS_SUBMODULES) DISTCLEANFILES = grids.f90 if FC_USE_MPI grids.f90: grids.f90_mpi -cp -f $< $@ else grids.f90: grids.f90_serial -cp -f $< $@ endif libcombinatorics_ut_la_SOURCES = \ md5_uti.f90 md5_ut.f90 \ sorting_uti.f90 sorting_ut.f90 \ grids_uti.f90 grids_ut.f90 \ solver_uti.f90 solver_ut.f90 ## Omitting this would exclude it from the distribution dist_noinst_DATA = combinatorics.nw # Modules and installation # Dump module names into file Modules execmoddir = $(fmoddir)/whizard nodist_execmod_HEADERS = \ - ${nodist_libcombinatorics_la_SOURCES:.f90=.$(FCMOD)} + ${COMBINAROTICS_MODULES:.f90=.$(FCMOD)} +#Submodules must not be included here libcombinatorics_Modules = \ - ${nodist_libcombinatorics_la_SOURCES:.f90=} \ + ${COMBINATORICS_MODULES:.f90=} \ ${libcombinatorics_ut_la_SOURCES:.f90=} Modules: Makefile @for module in \ $(libcombinatorics_Modules); do \ echo $$module >> $@.new; \ done @if diff $@ $@.new -q >/dev/null; then \ rm $@.new; \ else \ mv $@.new $@; echo "Modules updated"; \ fi BUILT_SOURCES = Modules ## Fortran module dependencies # Get module lists from other directories module_lists = \ ../basics/Modules \ ../testing/Modules \ ../system/Modules \ ../utilities/Modules $(module_lists): $(MAKE) -C `dirname $@` Modules Module_dependencies.sed: $(nodist_libcombinatorics_la_SOURCES) \ $(libcombinatorics_ut_la_SOURCES) Module_dependencies.sed: $(module_lists) @rm -f $@ echo 's/, *only:.*//' >> $@ echo 's/, *&//' >> $@ echo 's/, *.*=>.*//' >> $@ echo 's/$$/.lo/' >> $@ for list in $(module_lists); do \ dir="`dirname $$list`"; \ for mod in `cat $$list`; do \ echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \ done \ done DISTCLEANFILES += Module_dependencies.sed # The following line just says # include Makefile.depend # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE @am__include@ @am__quote@Makefile.depend@am__quote@ Makefile.depend: Module_dependencies.sed Makefile.depend: $(nodist_libcombinatorics_la_SOURCES) \ $(libcombinatorics_ut_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -f Module_dependencies.sed; \ done > $@ DISTCLEANFILES += Makefile.depend # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: # touch $@ AM_FCFLAGS = -I../basics -I../testing -I../system -I../utilities +######################################################################## +# For the moment, the submodule dependencies will be hard-coded +bytes_sub.lo: bytes.lo +hashes_sub.lo: hashes.lo +md5_sub.lo: md5.lo +permutations_sub.lo: permutations.lo ######################################################################## ## Default Fortran compiler options ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif # MPI if FC_USE_MPI AM_FCFLAGS += $(FCFLAGS_MPI) endif ######################################################################## ## Non-standard targets and dependencies ## (Re)create F90 sources from NOWEB source. if NOWEB_AVAILABLE FILTER = -filter "sed 's/defn MPI:/defn/'" PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw combinatorics.stamp: $(PRELUDE) $(srcdir)/combinatorics.nw $(POSTLUDE) @rm -f combinatorics.tmp @touch combinatorics.tmp for src in $(COMMON_F90) $(libcombinatorics_ut_la_SOURCES); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done + for src in $(COMBINATORICS_SUBMODULES); do \ + $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ + done for src in $(SERIAL_F90:.f90_serial=.f90); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src'_serial'; \ done for src in $(MPI_F90:.f90_mpi=.f90); do \ $(NOTANGLE) -R[[$$src]] $(FILTER) $^ | $(CPIF) $$src'_mpi'; \ done @mv -f combinatorics.tmp combinatorics.stamp -$(COMMON_F90) $(SERIAL_F90) $(MPI_F90) $(libcombinatorics_ut_la_SOURCES): combinatorics.stamp +$(COMMON_F90) $(COMBINATORICS_SUBMODULES) $(SERIAL_F90) $(MPI_F90) $(libcombinatorics_ut_la_SOURCES): combinatorics.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f combinatorics.stamp; \ $(MAKE) $(AM_MAKEFLAGS) combinatorics.stamp; \ fi endif - ######################################################################## ## Non-standard cleanup tasks ## Remove sources that can be recreated using NOWEB if NOWEB_AVAILABLE maintainer-clean-noweb: -rm -f *.f90 *.f90_serial *.f90_mpi *.c endif .PHONY: maintainer-clean-noweb ## Remove those sources also if builddir and srcdir are different if NOWEB_AVAILABLE clean-noweb: test "$(srcdir)" != "." && rm -f *.f90 *.f90_serial *.f90_mpi *.c || true endif .PHONY: clean-noweb ## Remove F90 module files clean-local: clean-noweb -rm -f combinatorics.stamp combinatorics.tmp -rm -f *.$(FCMOD) if FC_SUBMODULES -rm -f *.smod *.sub endif ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup