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]]>>=
 <<File header>>
 
 module file_utils
 
 <<Standard module head>>
 
 <<File utils: public>>
 
   interface
 <<File utils: sub interfaces>>
   end interface
 
 end module file_utils
 @ %def file_utils
 <<[[file_utils_sub.f90]]>>=
 <<File header>>
 
 submodule (file_utils) file_utils_s
- 
+
   use io_units
 
+  implicit none
+
 contains
 
 <<File utils: procedures>>
 
 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.
 <<File utils: public>>=
   public :: delete_file
 <<File utils: sub interfaces>>=
     module subroutine delete_file (name)
       character(*), intent(in) :: name
     end subroutine delete_file
 <<File utils: procedures>>=
   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]]>>=
 <<File header>>
 
 module file_registries
 
 <<Use strings>>
 
 <<Standard module head>>
 
 <<File registries: public>>
 
 <<File registries: types>>
 
   interface
 <<File registries: sub interfaces>>
   end interface
 
 end module file_registries
 @ %def file_registries
 @
 <<[[file_registries_sub.f90]]>>=
 <<File header>>
 
 submodule (file_registries) file_registries_s
 
   use io_units
 
+  implicit none
+
 contains
 
 <<File registries: procedures>>
 
 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.
 <<File registries: types>>=
   type :: file_handle_t
      type(string_t) :: file
      integer :: unit = 0
      integer :: refcount = 0
    contains
    <<File registries: file handle: TBP>>
   end type file_handle_t
 
 @ %def file_handle_t
 @ Debugging output:
 <<File registries: file handle: TBP>>=
   procedure :: write => file_handle_write
 <<File registries: sub interfaces>>=
     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
 <<File registries: procedures>>=
   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:
 <<File registries: file handle: TBP>>=
   procedure :: init => file_handle_init
 <<File registries: sub interfaces>>=
     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
 <<File registries: procedures>>=
   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.
 <<File registries: file handle: TBP>>=
   procedure :: open => file_handle_open
 <<File registries: sub interfaces>>=
     module subroutine file_handle_open (handle)
       class(file_handle_t), intent(inout) :: handle
     end subroutine file_handle_open
 <<File registries: procedures>>=
   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.
 <<File registries: file handle: TBP>>=
   procedure :: close => file_handle_close
 <<File registries: sub interfaces>>=
     module subroutine file_handle_close (handle)
       class(file_handle_t), intent(inout) :: handle
     end subroutine file_handle_close
 <<File registries: procedures>>=
   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.
 <<File registries: file handle: TBP>>=
   procedure :: is_open => file_handle_is_open
 <<File registries: sub interfaces>>=
     module function file_handle_is_open (handle) result (flag)
       class(file_handle_t), intent(in) :: handle
       logical :: flag
     end function file_handle_is_open
 <<File registries: procedures>>=
   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.
 <<File registries: file handle: TBP>>=
   procedure :: get_file => file_handle_get_file
 <<File registries: sub interfaces>>=
     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
 <<File registries: procedures>>=
   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.
 <<File registries: file handle: TBP>>=
   procedure :: get_unit => file_handle_get_unit
 <<File registries: sub interfaces>>=
     module function file_handle_get_unit (handle) result (unit)
       class(file_handle_t), intent(in) :: handle
       integer :: unit
     end function file_handle_get_unit
 <<File registries: procedures>>=
   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:
 <<File registries: types>>=
   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.
 <<File registries: public>>=
   public :: file_registry_t
 <<File registries: types>>=
   type :: file_registry_t
      type(file_entry_t), pointer :: first => null ()
    contains
    <<File registries: file registry: TBP>>
   end type file_registry_t
 
 @ %def file_registry_t
 @ Debugging output.
 <<File registries: file registry: TBP>>=
   procedure :: write => file_registry_write
 <<File registries: sub interfaces>>=
     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
 <<File registries: procedures>>=
   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.
 <<File registries: file registry: TBP>>=
   procedure :: open => file_registry_open
 <<File registries: sub interfaces>>=
     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
 <<File registries: procedures>>=
   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.
 <<File registries: file registry: TBP>>=
   procedure :: close => file_registry_close
 <<File registries: sub interfaces>>=
   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
 <<File registries: procedures>>=
   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]]>>=
 <<File header>>
 
 module string_utils
 
   use, intrinsic :: iso_c_binding
 
 <<Use kinds>>
 <<Use strings>>
 
 <<Standard module head>>
 
 <<String utils: public>>
 
 <<String utils: interfaces>>
 
   interface
 <<String utils: sub interfaces>>
   end interface
 
 end module string_utils
 @ %def string_utils
 @
 <<[[string_utils_sub.f90]]>>=
 <<File header>>
 
 submodule (string_utils) string_utils_s
 
+  implicit none
+
 contains
 
 <<String utils: procedures>>
 
 end submodule string_utils_s
 
 @ %def string_utils_s
 @
 \subsection{Upper and Lower Case}
 These are, unfortunately, not part of Fortran.
 <<String utils: public>>=
   public :: upper_case
   public :: lower_case
 <<String utils: interfaces>>=
   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
 <<String utils: sub interfaces>>=
     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
 <<String utils: procedures>>=
   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.
 <<String utils: public>>=
   public :: string_f2c
 <<String utils: interfaces>>=
   interface string_f2c
      module procedure string_f2c_char, string_f2c_var_str
   end interface string_f2c
 <<String utils: sub interfaces>>=
     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
 <<String utils: procedures>>=
   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.
 <<String utils: public>>=
   public :: strcpy_f2c
 <<String utils: sub interfaces>>=
     module subroutine strcpy_f2c (fstring, cstring)
       character(*), intent(in) :: fstring
       character(c_char), dimension(*), intent(inout) :: cstring
     end subroutine strcpy_f2c
 <<String utils: procedures>>=
   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.
 <<String utils: public>>=
   public :: string_c2f
 <<String utils: sub interfaces>>=
     module function string_c2f (cstring) result (fstring)
       character(c_char), dimension(*), intent(in) :: cstring
       character(:), allocatable :: fstring
     end function string_c2f
 <<String utils: procedures>>=
   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.
 <<String utils: public>>=
   public :: str
 <<String utils: interfaces>>=
   interface str
      module procedure str_log, str_logs, str_int, str_ints, &
             str_real, str_reals, str_complex, str_complexs
   end interface
 <<String utils: sub interfaces>>=
     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
 <<String utils: procedures>>=
   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
     <<concatenate strings>>
   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
     <<concatenate strings>>
   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
     <<concatenate strings>>
   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
     <<concatenate strings>>
   end function str_complexs
 
 @ %def str
 <<concatenate strings>>=
 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.
 <<String utils: public>>=
   public :: read_rval
   public :: read_ival
 <<String utils: sub interfaces>>=
     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
 <<String utils: procedures>>=
   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}
 <<String utils: public>>=
   public :: string_contains_word
 <<String utils: sub interfaces>>=
     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
 <<String utils: procedures>>=
   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.
 <<String utils: public>>=
   public :: split_string
 <<String utils: sub interfaces>>=
     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
 <<String utils: procedures>>=
   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]]>>=
 <<File header>>
 
 module format_utils
 
 <<Use kinds>>
 <<Use strings>>
 
 <<Standard module head>>
 
 <<Format utils: public>>
 
   interface
 <<Format utils: sub interfaces>>
   end interface
 
 end module format_utils
 @ %def format_utils
 @
 <<[[format_utils_sub.f90]]>>=
 <<File header>>
 
 submodule (format_utils) format_utils_s
 
   use string_utils, only: lower_case
   use io_units, only: given_output_unit
-  
+
+  implicit none
+
 contains
 
 <<Format utils: procedures>>
 
 end submodule format_utils_s
 
 @ %def format_utils_s
 @
 \subsection{Line Output}
 Write a separator line.
 <<Format utils: public>>=
   public :: write_separator
 <<Format utils: sub interfaces>>=
     module subroutine write_separator (u, mode)
       integer, intent(in) :: u
       integer, intent(in), optional :: mode
     end subroutine write_separator
 <<Format utils: procedures>>=
   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.
 <<Format utils: public>>=
   public :: write_indent
 <<Format utils: sub interfaces>>=
     module subroutine write_indent (unit, indent)
       integer, intent(in) :: unit
       integer, intent(in), optional :: indent
     end subroutine write_indent
 <<Format utils: procedures>>=
   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.
 <<Format utils: public>>=
   public :: write_integer_array
 <<Format utils: sub interfaces>>=
     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
 <<Format utils: procedures>>=
   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.
 <<Format utils: public>>=
   public :: quote_underscore
 <<Format utils: sub interfaces>>=
     module function quote_underscore (string) result (quoted)
       type(string_t) :: quoted
       type(string_t), intent(in) :: string
     end function quote_underscore
 <<Format utils: procedures>>=
   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.
 <<Format utils: public>>=
   public :: tex_format
 <<Format utils: sub interfaces>>=
     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
 <<Format utils: procedures>>=
   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:
 <<Format utils: public>>=
   public :: mp_format
 <<Format utils: sub interfaces>>=
     module function mp_format (rval) result (string)
       type(string_t) :: string
       real(default), intent(in) :: rval
     end function mp_format
 <<Format utils: procedures>>=
   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.
 <<Format utils: public>>=
   public :: pac_fmt
 <<Format utils: sub interfaces>>=
     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
 <<Format utils: procedures>>=
   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.
 <<Format utils: public>>=
   public :: refmt_tiny
 <<Format utils: sub interfaces>>=
     elemental module function refmt_tiny (val) result (trunc_val)
       real(default), intent(in) :: val
       real(default) :: trunc_val
     end function refmt_tiny
 <<Format utils: procedures>>=
   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}
 <<Format utils: public>>=
   public :: write_compressed_integer_array
 <<Format utils: sub interfaces>>=
     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
 <<Format utils: procedures>>=
   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]]>>=
 <<File header>>
 
 module format_defs
 
 <<Standard module head>>
 
 <<Format defs: public parameters>>
 
 end module format_defs
 @ %def format_defs
 @ We collect format strings for various numerical output formats here.
 <<Format defs: public parameters>>=
   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.
 <<Format defs: public parameters>>=
   character(*), parameter, public :: FMF_12 = "F12.9"
 @ %def FMF_12
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Numeric Utilities}
 
 <<[[numeric_utils.f90]]>>=
 <<File header>>
 
 module numeric_utils
 
 <<Use kinds>>
 <<Use strings>>
 
 <<Standard module head>>
 
 <<Numeric utils: public>>
 
 <<Numeric utils: parameters>>
 
 <<Numeric utils: types>>
 
 <<Numeric utils: interfaces>>
 
   interface
 <<Numeric utils: sub interfaces>>
   end interface
 
 end module numeric_utils
 @ %def numeric_utils
 @
 <<[[numeric_utils_sub.f90]]>>=
 <<File header>>
 
 submodule (numeric_utils) numeric_utils_s
 
   use string_utils
   use constants
   use format_defs
 
+  implicit none
+
 contains
 
 <<Numeric utils: procedures>>
 
 end submodule numeric_utils_s
 
 @ %def numeric_utils_s
 @
 <<Numeric utils: public>>=
   public :: assert
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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.
 <<Numeric utils: public>>=
   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
 
 @
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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
 @
 <<Numeric utils: sub interfaces>>= 
     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
 <<Numeric utils: procedures>>=
   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
 @
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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
 @
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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
 @
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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
 @
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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.
 <<Numeric utils: procedures>>=
   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.
 <<Numeric utils: public>>=
   public :: nearly_equal
 <<Numeric utils: interfaces>>=
   interface nearly_equal
      module procedure nearly_equal_real
      module procedure nearly_equal_complex
   end interface nearly_equal
 
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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:
 <<Numeric utils: public>>=
   public:: vanishes
   interface vanishes
      module procedure vanishes_real, vanishes_complex
   end interface
 @
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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
 @
 <<Numeric utils: public>>=
   public :: expanded_amp2
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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
 @
 <<Numeric utils: public>>=
   public :: abs2
 <<Numeric utils: sub interfaces>>=
     elemental module function abs2 (c) result (c2)
       real(default) :: c2
       complex(default), intent(in) :: c
     end function abs2
 <<Numeric utils: procedures>>=
   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
 <<Numeric utils: public>>=
   public:: remove_array_element
   interface remove_array_element
      module procedure remove_array_element_logical
   end interface
 @
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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.
 <<Numeric utils: public>>=
   public :: remove_duplicates_from_int_array
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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
 @
 <<Numeric utils: public>>=
   public :: extend_integer_array
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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
 @
 <<Numeric utils: public>>=
   public :: crop_integer_array
 <<Numeric utils: sub interfaces>>=
     module subroutine crop_integer_array (list, i_crop)
       integer, intent(inout), dimension(:), allocatable :: list
       integer, intent(in) :: i_crop
     end subroutine crop_integer_array
 <<Numeric utils: procedures>>=
   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$.
 <<Numeric utils: public>>=
   public :: log_prec
 <<Numeric utils: sub interfaces>>=
     module function log_prec (x, xb) result (lx)
       real(default), intent(in) :: x, xb
       real(default) :: lx
     end function log_prec
 <<Numeric utils: procedures>>=
   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
 @
 <<Numeric utils: public>>=
   public :: split_array
 <<Numeric utils: interfaces>>=
   interface split_array
      module procedure split_integer_array
      module procedure split_real_array
   end interface
 <<Numeric utils: sub interfaces>>=
     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
 <<Numeric utils: procedures>>=
   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]]>>=
 <<File header>>
 module binary_tree
 
-  implicit none
-
-  private
+<<Standard module head>>
 
 <<Binary trees: public>>
   
 <<Binary trees: types>>
 
   interface
 <<Binary trees: sub interfaces>>
   end interface
 
 contains
 
 <<Binary trees: module procedures>>
   
 end module binary_tree
 @ %def binary_tree
 @
 <<[[binary_tree_sub.f90]]>>=
 <<File header>>
 
 submodule (binary_tree) binary_tree_s
 
   use io_units
 
+  implicit none
+
 contains
 
 <<Binary trees: procedures>>
 
 end submodule binary_tree_s
 
 @ %def binary_tree_s
 @
 <<Binary trees: public>>=
   public :: binary_tree_iterator_t 
 <<Binary trees: types>>=
   type :: binary_tree_iterator_t
      integer, dimension(:), allocatable :: key
      integer :: current
      !! current \in {1, N}.
    contains
    <<Binary trees: iterator: TBP>>
   end type binary_tree_iterator_t
 
 @ %def binary_tree_iterator_t
 @ 
 <<Binary trees: types>>=
   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
    <<Binary trees: node: TBP>>
   end type binary_tree_node_t
 
 @ %def binary_tree_node_t
 @
 <<Binary trees: public>>=
   public :: binary_tree_t
 <<Binary trees: types>>=
   type :: binary_tree_t
      integer :: n_elements = 0
      type(binary_tree_node_t), pointer :: root => null ()
    contains
    <<Binary trees: tree: TBP>>
   end type binary_tree_t
 
 @ %def binary_tree_t
 @
 <<Binary trees: iterator: TBP>>=
   procedure :: init => binary_tree_iterator_init
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   !! 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
 @
 <<Binary trees: iterator: TBP>>=
   procedure :: is_iterable => binary_tree_iterator_is_iterable
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: iterator: TBP>>=
   procedure :: next => binary_tree_iterator_next
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: node: TBP>>=
   procedure :: init => binary_tree_node_init
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: node: TBP>>=
   procedure :: write => binary_tree_node_write
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: node: TBP>>=
   procedure :: get_balance => binary_tree_node_get_balance
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: node: TBP>>=
   procedure :: increment_height => binary_tree_node_increment_height
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   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
 @ 
 <<Binary trees: node: TBP>>=
   final :: binary_tree_node_final
 <<Binary trees: sub interfaces>>=
     !!! !!! 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
 <<Binary trees: module procedures>>=
   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
 @
 <<Binary trees: tree: TBP>>=
   procedure :: write => binary_tree_write
 <<Binary trees: sub interfaces>>=
     module subroutine binary_tree_write (btree, unit)
       class(binary_tree_t), intent(in) :: btree
       integer, intent(in), optional :: unit
     end subroutine binary_tree_write
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: tree: TBP>>=
   final :: binary_tree_final
 <<Binary trees: sub interfaces>>=
     !!! !!! 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
 <<Binary trees: module procedures>>=
   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
 @
 <<Binary trees: tree: TBP>>=
   procedure :: clear => binary_tree_clear
 <<Binary trees: sub interfaces>>=
     module subroutine binary_tree_clear (btree)
       class(binary_tree_t), intent(inout) :: btree
     end subroutine binary_tree_clear
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: tree: TBP>>=
   procedure :: get_n_elements => binary_tree_get_n_elements
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: tree: TBP>>=
   procedure :: insert => binary_tree_insert
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: tree: TBP>>=
   procedure, private :: insert_node => binary_tree_insert_node
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: tree: TBP>>=
   procedure, private :: balance => binary_tree_balance
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   !! 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
 @
 <<Binary trees: tree: TBP>>=
   procedure :: search => binary_tree_search
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: tree: TBP>>=
   procedure :: has_key => binary_tree_has_key
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   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
 @
 <<Binary trees: tree: TBP>>=
   procedure, private :: rotate_right => binary_tree_rotate_right
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   !!      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
 @
 <<Binary trees: tree: TBP>>=
   procedure, private :: rotate_left => binary_tree_rotate_left
 <<Binary trees: sub interfaces>>=
     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
 <<Binary trees: procedures>>=
   !!      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]]>>=
 <<File header>>
 
 module binary_tree_ut
   use unit_tests
   use binary_tree_uti
 
 <<Standard module head>>
 
 <<Binary tree: public test>>
 
  contains
 
 <<Binary tree: test driver>>
 
 end module binary_tree_ut
 @ %def binary_tree_ut
 @
 <<[[binary_tree_uti.f90]]>>=
 <<File header>>
 
 module binary_tree_uti
 
   use binary_tree
 
 <<Standard module head>>
 
   type :: btree_obj_t
      integer :: i = 0
   end type btree_obj_t
 
 <<Binary tree: test declarations>>
 
  contains
 
 <<Binary tree: tests>>
 
 end module binary_tree_uti
 @ %def binary_tree_uti
 @
 <<Binary tree: public test>>=
 public :: binary_tree_test
 <<Binary tree: test driver>>=
 subroutine binary_tree_test (u, results)
   integer, intent(in) :: u
   type(test_results_t), intent(inout) :: results
   <<Binary tree: execute tests>>
 end subroutine binary_tree_test
 
 @ %def binary_tree_test
 @ Provide testing for interface stability and correct implementation for the
 binary tree and its iterator.
 <<Binary tree: execute tests>>=
 call test (binary_tree_1, "binary_tree_1", &
      "check interface and implementation", &
      u, results)
 <<Binary tree: test declarations>>=
 public :: binary_tree_1
 <<Binary tree: tests>>=
 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]]>>=
 <<File header>>
 
 module array_list
 <<Use kinds>>
 
-  implicit none
-
-  private
+<<Standard module head>>
 
 <<Array list: public>>
 
 <<Array list: parameters>>
 
 <<Array list: types>>
 
   interface
 <<Array list: sub interfaces>>
   end interface
 
 end module array_list
 @ %def array_list
 @
 <<[[array_list_sub.f90]]>>=
 <<File header>>
 
 submodule (array_list) array_list_s
 
   use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
   use io_units
 
+  implicit none
+
 contains
 
 <<Array list: procedures>>
 
 end submodule array_list_s
 
 @ %def array_list_s
 @
 <<Array list: parameters>>=
   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
 @
 <<Array list: public>>=
   public :: array_list_t
 <<Array list: types>>=
   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
    <<Array list: array list: TBP>>
   end type array_list_t
 
 @ %def array_list_t
 @
 <<Array list: array list: TBP>>=
   procedure :: write => array_list_write
 <<Array list: sub interfaces>>=
     module subroutine array_list_write (list, unit)
       class(array_list_t), intent(in) :: list
       integer, intent(in), optional :: unit
     end subroutine array_list_write
 <<Array list: procedures>>=
   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 
 @
 <<Array list: array list: TBP>>=
   procedure :: init => array_list_init
 <<Array list: sub interfaces>>=
     module subroutine array_list_init (list)
       class(array_list_t), intent(out) :: list
     end subroutine array_list_init
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: get => array_list_get
 <<Array list: sub interfaces>>=
     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
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: get_count => array_list_get_count
 <<Array list: sub interfaces>>=
     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
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: get_size => array_list_get_size
 <<Array list: sub interfaces>>=
     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
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: is_full => array_list_is_full
 <<Array list: sub interfaces>>=
     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
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: is_empty => array_list_is_empty
 <<Array list: sub interfaces>>=
     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
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: is_index => array_list_is_index
 <<Array list: sub interfaces>>=
     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
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: clear => array_list_clear
 <<Array list: sub interfaces>>=
     module subroutine array_list_clear (list)
       class(array_list_t), intent(inout) :: list
     end subroutine array_list_clear
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: add => array_list_add
 <<Array list: sub interfaces>>=
     module subroutine array_list_add (list, data)
       class(array_list_t), intent(inout) :: list
       integer, intent(in) :: data
     end subroutine array_list_add
 <<Array list: procedures>>=
   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 
 @
 <<Array list: array list: TBP>>=
   procedure :: grow_size => array_list_grow_size
 <<Array list: sub interfaces>>=
     module subroutine array_list_grow_size (list)
       class(array_list_t), intent(inout) :: list
     end subroutine array_list_grow_size
 <<Array list: procedures>>=
   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 
 @
 <<Array list: array list: TBP>>=
   procedure :: shrink_size => array_list_shrink_size
 <<Array list: sub interfaces>>=
     module subroutine array_list_shrink_size (list)
       class(array_list_t), intent(inout) :: list
       integer, dimension(:), allocatable :: array
     end subroutine array_list_shrink_size
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: reverse_order => array_list_reverse_order
 <<Array list: sub interfaces>>=
     module subroutine array_list_reverse_order (list)
       class(array_list_t), intent(inout) :: list
     end subroutine array_list_reverse_order
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: sort => array_list_sort
 <<Array list: sub interfaces>>=
     pure module subroutine array_list_sort (list)
       class(array_list_t), intent(inout) :: list
     end subroutine array_list_sort
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: is_element => array_list_is_element
 <<Array list: sub interfaces>>=
     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
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: find => array_list_find
 <<Array list: sub interfaces>>=
     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
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: add_at => array_list_add_at
 <<Array list: sub interfaces>>=
     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
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: remove => array_list_remove
 <<Array list: sub interfaces>>=
     module function array_list_remove (list) result (data)
       class(array_list_t), intent(inout) :: list
       integer :: data
     end function array_list_remove
 <<Array list: procedures>>=
   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
 @
 <<Array list: array list: TBP>>=
   procedure :: remove_at => array_list_remove_at
 <<Array list: sub interfaces>>=
     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
 <<Array list: procedures>>=
   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]]>>=
 <<File header>>
 
 module array_list_ut
   use unit_tests
   use array_list_uti
 
 <<Standard module head>>
 
 <<Array list: public test>>
 
  contains
 
 <<Array list: test driver>>
 end module array_list_ut
 @ %def array_list_ut
 @
 <<[[array_list_uti.f90]]>>=
 <<File header>>
 
 module array_list_uti
 
   use array_list
 
 <<Standard module head>>
 
 <<Array list: test declarations>>
 
  contains
 
 <<Array list: tests>>
 
 end module array_list_uti
 @ %def array_list_uti
 @
 <<Array list: public test>>=
 public :: array_list_test
 <<Array list: test driver>>=
 subroutine array_list_test (u, results)
   integer, intent(in) :: u
   type(test_results_t), intent(inout) :: results
   <<Array list: execute tests>>
 end subroutine array_list_test
 
 @ %def array_list_test
 @ Provide testing for interface stability and correct implementation for the
 binary tree and its iterator.
 <<Array list: execute tests>>=
 call test (array_list_1, "array_list_1", &
      "check interface and implementation", &
      u, results)
 <<Array list: test declarations>>=
 public :: array_list_1
 <<Array list: tests>>=
 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]]>>=
 <<File header>>
 
 module queue
 
-  implicit none
-
-  private
+<<Standard module head>>
 
 <<Queue: public>>
 
 <<Queue: parameters>>
 
 <<Queue: types>>
 
   interface
 <<Queue: sub interfaces>>
   end interface
 
 end module queue
 @ %def queue
 @
 <<[[queue_sub.f90]]>>=
 <<File header>>
 
 submodule (queue) queue_s
 
   use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
 
+  implicit none
+
 contains
 
 <<Queue: procedures>>
 
 end submodule queue_s
 
 @ %def queue_s
 @
 <<Queue: parameters>>=
   integer, parameter :: QUEUE_SIZE = 10, &
        QUEUE_START = 0, &
        QUEUE_END = QUEUE_SIZE
 
 @  %def queue_size queue_start queue_end
 @ 
 <<Queue: public>>=
   public :: queue_t
 <<Queue: types>>=
   type :: queue_t
      private
      integer, dimension(QUEUE_SIZE) :: item
      integer :: front = 0
      integer :: rear = 0
    contains
    <<Queue: queue: TBP>>
   end type queue_t
 
 @ %def queue_t
 @
 <<Queue: queue: TBP>>=
   procedure :: is_full => queue_is_full
 <<Queue: sub interfaces>>=
     elemental module function queue_is_full (queue) result (flag)
       class(queue_t), intent(in) :: queue
       logical :: flag
     end function queue_is_full
 <<Queue: procedures>>=
   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
 @
 <<Queue: queue: TBP>>=
   procedure :: is_empty => queue_is_empty
 <<Queue: sub interfaces>>=
     elemental module function queue_is_empty (queue) result (flag)
       class(queue_t), intent(in) :: queue
       logical :: flag
     end function queue_is_empty
 <<Queue: procedures>>=
   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
 @
 <<Queue: queue: TBP>>=
   procedure :: enqueue => queue_enqueue
 <<Queue: sub interfaces>>=
     module subroutine queue_enqueue (queue, item)
       class(queue_t), intent(inout) :: queue
       integer, intent(in) :: item
     end subroutine queue_enqueue
 <<Queue: procedures>>=
   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
 @
 <<Queue: queue: TBP>>=
   procedure :: dequeue => queue_dequeue
 <<Queue: sub interfaces>>=
     module function queue_dequeue (queue) result (item)
       class(queue_t), intent(inout) :: queue
       integer :: item
     end function queue_dequeue
 <<Queue: procedures>>=
   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
 @
 <<Queue: queue: TBP>>=
   procedure :: peek => queue_peek
 <<Queue: sub interfaces>>=
     module function queue_peek (queue) result (item)
       class(queue_t), intent(in) :: queue
       integer :: item
     end function queue_peek
 <<Queue: procedures>>=
   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
 @
 <<Queue: queue: TBP>>=
   procedure :: write => queue_write
 <<Queue: sub interfaces>>=
     module subroutine queue_write (queue, unit)
       class(queue_t), intent(in) :: queue
       integer, intent(in), optional :: unit
     end subroutine queue_write
 <<Queue: procedures>>=
   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]]>>=
 <<File header>>
 module iterator
 
-  implicit none
-
-  private
+<<Standard module head>>
 
 <<Iterator: public>>
 
 <<Iterator: types>>
 
   interface
 <<Iterator: sub interfaces>>
   end interface
 
 end module iterator
 
 @ %def iterator
 @
 <<[[iterator_sub.f90]]>>=
 <<File header>>
 
 submodule (iterator) iterator_s
 
   use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
 
+  implicit none
+
 contains
 
 <<Iterator: procedures>>
 
 end submodule iterator_s
 
 @ %def iterator_s
 @
 <<Iterator: public>>=
   public :: iterator_t
 <<Iterator: types>>=
   !! Forward
   type :: iterator_t
      integer :: current = 0
      integer :: begin = 0
      integer :: end = 0
      integer :: step = 1
    contains
    <<Iterator: iterator: TBP>>
   end type iterator_t
 
 @ %def iterator_t
 @
 <<Iterator: iterator: TBP>>=
   procedure :: write => iterator_write
 <<Iterator: sub interfaces>>=
     module subroutine iterator_write (iter, unit)
       class(iterator_t), intent(in) :: iter
       integer, intent(in), optional :: unit
     end subroutine iterator_write
 <<Iterator: procedures>>=
   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
 @
 <<Iterator: iterator: TBP>>=
   procedure :: init => iterator_init
 <<Iterator: sub interfaces>>=
    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
 <<Iterator: procedures>>=
   !! 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
 @
 <<Iterator: iterator: TBP>>=
   procedure :: at_begin => iterator_at_begin
 <<Iterator: sub interfaces>>=
     pure module function iterator_at_begin (iter) result (flag)
       class(iterator_t), intent(in) :: iter
       logical :: flag
     end function iterator_at_begin
 <<Iterator: procedures>>=
   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
 @
 <<Iterator: iterator: TBP>>=
   procedure :: at_end => iterator_at_end
 <<Iterator: sub interfaces>>=
     pure module function iterator_at_end (iter) result (flag)
       class(iterator_t), intent(in) :: iter
       logical :: flag
     end function iterator_at_end
 <<Iterator: procedures>>=
   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
 @
 <<Iterator: iterator: TBP>>=
   procedure :: is_iterable => iterator_is_iterable
 <<Iterator: sub interfaces>>=
     pure module function iterator_is_iterable (iter) result (flag)
       class(iterator_t), intent(in) :: iter
       logical :: flag
     end function iterator_is_iterable
 <<Iterator: procedures>>=
   !! 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
 @
 <<Iterator: iterator: TBP>>=
   procedure :: next_step => iterator_next_step
 <<Iterator: sub interfaces>>=
     module subroutine iterator_next_step (iter)
       class(iterator_t), intent(inout) :: iter
     end subroutine iterator_next_step
 <<Iterator: procedures>>=
   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
 @
 <<Iterator: iterator: TBP>>=
   procedure :: next => iterator_next
 <<Iterator: sub interfaces>>=
     module function iterator_next (iter) result (ndx)
       class(iterator_t), intent(inout) :: iter
       integer :: ndx
     end function iterator_next
 <<Iterator: procedures>>=
   !! 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
 @
 <<Iterator: iterator: TBP>>=
   procedure :: get_current => iterator_get_current
 <<Iterator: sub interfaces>>=
     pure module function iterator_get_current (iter) result (ndx)
       class(iterator_t), intent(in) :: iter
       integer :: ndx
     end function iterator_get_current
 <<Iterator: procedures>>=
   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]]>>=
 <<File header>>
 
 module iterator_ut
   use unit_tests
   use iterator_uti
 
 <<Standard module head>>
 
 <<Iterator: public test>>
 
  contains
 
 <<Iterator: test driver>>
 end module iterator_ut
 @ %def iterator_ut
 @
 <<[[iterator_uti.f90]]>>=
 <<File header>>
 
 module iterator_uti
 
   use iterator
 
 <<Standard module head>>
 
 <<Iterator: test declarations>>
 
  contains
 
 <<Iterator: tests>>
 
 end module iterator_uti
 @ %def iterator_uti
 @
 <<Iterator: public test>>=
 public :: iterator_test
 <<Iterator: test driver>>=
 subroutine iterator_test (u, results)
   integer, intent(in) :: u
   type(test_results_t), intent(inout) :: results
   <<Iterator: execute tests>>
 end subroutine iterator_test
 
 @ %def iterator_test
 @ Provide testing for interface stability and correct implementation for the
 forward integer iterator.
 <<Iterator: execute tests>>=
 call test (iterator_1, "iterator_1", &
      "check interface and implementation", &
      u, results)
 <<Iterator: test declarations>>=
 public :: iterator_1
 <<Iterator: tests>>=
 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/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]]>>=
 <<File header>>
 
 module electron_pdfs
 
 <<Use kinds>>
 <<electron pdfs use>>
   
 <<Standard module head>>
 
 <<Electron PDFs: public>>
 
 <<Electron PDFs: types>>
 
   interface
 <<Electron PDFs: sub interfaces>>
   end interface
 
 end module electron_pdfs
 @ %def electron_pdfs 
 @
 <<electron pdfs use>>=
   use io_units
 @ %def electron_pdfs use
 @
 <<[[electron_pdfs_sub.f90]]>>=
 <<File header>>
 
 submodule (electron_pdfs) electron_pdfs_s
 
 <<Use strings>>
 <<electron pdfs use>>
   use constants, only: pi
   use format_defs, only: FMT_19
   use numeric_utils
   use sm_physics, only: Li2, zeta2, zeta3
 
+  implicit none
+
 contains
 
 <<Electron PDFs: procedures>>
 
 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:
 <<Electron PDFs: public>>=
   public :: qed_pdf_t
 <<Electron PDFs: types>>=
   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
    <<Electron PDFs: QED PDF: TBP>>
   end type qed_pdf_t
 
 @ %def qed_pdf_t 
 @
 <<Electron PDFs: QED PDF: TBP>>=
   procedure :: init => qed_pdf_init
 <<Electron PDFs: sub interfaces>>=
     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
 <<Electron PDFs: procedures>>=
   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.
 <<Electron PDFs: QED PDF: TBP>>=
   procedure :: write => qed_pdf_write
 <<Electron PDFs: sub interfaces>>=
     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
 <<Electron PDFs: procedures>>=
   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. 
 <<Electron PDFs: QED PDF: TBP>>=
   procedure :: set_order => qed_pdf_set_order
 <<Electron PDFs: sub interfaces>>=
     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
 <<Electron PDFs: procedures>>=
   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.
 <<Electron PDFs: QED PDF: TBP>>=
   procedure :: evolve_qed_pdf => qed_pdf_evolve_qed_pdf
 <<Electron PDFs: sub interfaces>>=
     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
 <<Electron PDFs: procedures>>=
   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/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]]>>=
 <<File header>>
 
 module system_defs
 
   use, intrinsic :: iso_fortran_env, only: iostat_end, iostat_eor !NODEP!
 
 <<Standard module head>>
 
 <<System defs: public parameters>>
 
 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.
 <<System defs: public parameters>>=
   integer, parameter, public :: VERSION_STRLEN = 255
   character(len=VERSION_STRLEN), parameter, public :: &
        & VERSION_STRING = "WHIZARD version <<Version>> (<<Date>>)"
 
 @ %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.
 <<System defs: public parameters>>=
   integer, parameter, public :: BUFFER_SIZE = 1000
 
 @ %def BUFFER_SIZE
 @
 \subsection{IOSTAT Codes}
 Defined in [[iso_fortran_env]], but we would like to use shorthands.
 <<System defs: public parameters>>=
   integer, parameter, public :: EOF = iostat_end,  EOR = iostat_eor
 
 @ %def EOF EOR
 @
 \subsection{Character Codes}
 Single-character constants.
 <<System defs: public parameters>>=
   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.
 <<System defs: public parameters>>=
   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]]>>=
 /*
 <<File header>>
 */
 #include <signal.h>
 #include <stdlib.h>
 
 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]]>>=
 /*
 <<File header>>
 */
 #include <stdio.h>
 
 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);
 }
 
 <<sprintf interfaces>>=
   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]]>>=
 <<File header>>
 
 module diagnostics
 
   use, intrinsic :: iso_c_binding !NODEP!
 
 <<Use kinds>>
 <<Use strings>>
 
   use system_defs, only: BUFFER_SIZE, MAX_ERRORS
 
 <<Standard module head>>
 
 <<Diagnostics: public>>
 
 <<Diagnostics: parameters>>
 
 <<Diagnostics: types>>
 
 <<Diagnostics: variables>>
 
 <<Diagnostics: interfaces>>
 
   interface
 <<Diagnostics: sub interfaces>>
   end interface
 
 end module diagnostics
 
 <<Diagnostics: external procedures>>
 @ %def diagnostics
 @
 <<[[diagnostics_sub.f90]]>>=
 <<File header>>
 
 submodule (diagnostics) diagnostics_s
 
   use, intrinsic :: iso_fortran_env, only: output_unit !NODEP!
 
   use system_dependencies
 <<Use debug>>
   use string_utils, only: str
   use io_units
 
+  implicit none
+
 contains
 
 <<Diagnostics: procedures>>
 
 end submodule diagnostics_s
 
 @ %def diagnostics_s
 @
 Diagnostics levels:
 <<Diagnostics: public>>=
   public :: RESULT, DEBUG, DEBUG2
 <<Diagnostics: parameters>>=
   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:
 <<Diagnostics: public>>=
   public :: d_area
 <<Diagnostics: interfaces>>=
   interface d_area
      module procedure d_area_of_string
      module procedure d_area_to_string
   end interface
 <<Diagnostics: sub interfaces>>=
     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
 <<Diagnostics: procedures>>=
   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
 @
 <<Diagnostics: public>>=
   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
 <<Diagnostics: parameters>>=
   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
 @
 <<Diagnostics: public>>=
   public :: msg_level
 <<Diagnostics: variables>>=
   integer, save, dimension(D_ALL:D_LAST) :: msg_level = RESULT
 @ %def msg_level
 @
 <<Diagnostics: parameters>>=
   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
 @
 <<Diagnostics: public>>=
   public :: set_debug_levels
 <<Diagnostics: sub interfaces>>=
     module subroutine set_debug_levels (area_str)
       type(string_t), intent(in) :: area_str
     end subroutine set_debug_levels
 <<Diagnostics: procedures>>=
   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
 @
 <<Diagnostics: public>>=
   public :: set_debug2_levels
 <<Diagnostics: sub interfaces>>=
     module subroutine set_debug2_levels (area_str)
       type(string_t), intent(in) :: area_str
     end subroutine set_debug2_levels
 <<Diagnostics: procedures>>=
   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
 @
 <<Diagnostics: types>>=
   type :: terminal_color_t
      integer :: color = COL_UNDEFINED
   contains
   <<Diagnostics: terminal color: TBP>>
   end type terminal_color_t
 
 @ %def terminal_color_t
 @
 <<Diagnostics: public>>=
   public :: term_col
 <<Diagnostics: interfaces>>=
   interface term_col
      module procedure term_col_int
      module procedure term_col_char
   end interface term_col
 
 @ %def term_col
 @
 <<Diagnostics: sub interfaces>>=
     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
 <<Diagnostics: procedures>>=
   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.
 <<Diagnostics: public>>=
   public :: mask_fatal_errors
 <<Diagnostics: variables>>=
   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.
 <<Diagnostics: parameters>>=
   integer, parameter, public :: TERM_STOP = 0, TERM_EXIT = 1, TERM_CRASH = 2
 @ %def TERM_STOP TERM_EXIT TERM_CRASH
 <<Diagnostics: public>>=
   public :: handle_fatal_errors
 <<Diagnostics: variables>>=
   integer, save :: handle_fatal_errors = TERM_EXIT
 <<Diagnostics: external procedures>>=
   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.
 <<Diagnostics: public>>=
   public :: msg_count
 <<Diagnostics: variables>>=
   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.
 <<Diagnostics: types>>=
   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
 <<Diagnostics: variables>>=
   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.
 <<Diagnostics: procedures>>=
   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:
 <<Diagnostics: public>>=
   public :: msg_list_clear
 <<Diagnostics: sub interfaces>>=
     module subroutine msg_list_clear
     end subroutine msg_list_clear
 <<Diagnostics: procedures>>=
   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)
 <<Diagnostics: public>>=
   public :: msg_summary
 <<Diagnostics: sub interfaces>>=
     module subroutine msg_summary (unit)
       integer, intent(in), optional :: unit
     end subroutine msg_summary
 <<Diagnostics: procedures>>=
   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.
 <<Diagnostics: public>>=
   public :: msg_listing
 <<Diagnostics: sub interfaces>>=
     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
 <<Diagnostics: procedures>>=
   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:
 <<Diagnostics: public>>=
   public :: msg_buffer
 <<Diagnostics: variables>>=
   character(len=BUFFER_SIZE), save :: msg_buffer = " "
 @ %def msg_buffer
 @
 After a message is issued, the buffer should be cleared:
 <<Diagnostics: procedures>>=
   subroutine buffer_clear
     msg_buffer = " "
   end subroutine buffer_clear
 
 @ %def buffer_clear
 <<Diagnostics: public>>=
   public :: create_col_string
 <<Diagnostics: sub interfaces>>=
     module function create_col_string (color) result (col_string)
        type(string_t) :: col_string
        integer, intent(in) :: color
     end function create_col_string
 <<Diagnostics: procedures>>=
   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).
 <<Diagnostics: procedures>>=
   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.
 <<System defs: public parameters>>=
   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.
 <<Diagnostics: public>>=
   public :: msg_terminate
   public :: msg_bug, msg_fatal, msg_error, msg_warning
   public :: msg_message, msg_result
 <<Diagnostics: sub interfaces>>=
   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
 <<Diagnostics: procedures>>=
   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.
 <<debug guard>>=
 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.
 <<Diagnostics: public>>=
   public :: msg_debug
 <<Diagnostics: interfaces>>=
   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
 <<Diagnostics: sub interfaces>>=
     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
 <<Diagnostics: procedures>>=
   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
        <<debug guard>>
     end if
   end subroutine msg_debug_none
 
   module subroutine msg_debug_logical (area, string, value, color)
     logical, intent(in) :: value
   <<msg debug implementation>>
   end subroutine msg_debug_logical
 
   module subroutine msg_debug_integer (area, string, value, color)
     integer, intent(in) :: value
   <<msg debug implementation>>
   end subroutine msg_debug_integer
 
   module subroutine msg_debug_real (area, string, value, color)
     real(default), intent(in) :: value
   <<msg debug implementation>>
   end subroutine msg_debug_real
 
   module subroutine msg_debug_complex (area, string, value, color)
     complex(default), intent(in) :: value
   <<msg debug implementation>>
   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
        <<debug guard>>
     end if
   end subroutine msg_debug_string
 
 @ %def msg_debug
 <<msg debug implementation>>=
   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
      <<debug guard>>
   end if
 @
 <<Diagnostics: public>>=
   public :: msg_print_color
 <<Diagnostics: interfaces>>=
   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
 <<Diagnostics: sub interfaces>>=
     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
 <<Diagnostics: procedures>>=
   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.]].
 <<debug2 guard>>=
 if (.not. debug_on)  call msg_bug ("msg_debug2 called with debug_on=.false.")
 <<Diagnostics: public>>=
   public :: msg_debug2
 <<Diagnostics: interfaces>>=
   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
 <<Diagnostics: sub interfaces>>=
     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
 <<Diagnostics: procedures>>=
   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
        <<debug2 guard>>
     end if
   end subroutine msg_debug2_none
 
   module subroutine msg_debug2_logical (area, string, value, color)
     logical, intent(in) :: value
   <<msg debug2 implementation>>
   end subroutine msg_debug2_logical
 
   module subroutine msg_debug2_integer (area, string, value, color)
     integer, intent(in) :: value
   <<msg debug2 implementation>>
   end subroutine msg_debug2_integer
 
   module subroutine msg_debug2_real (area, string, value, color)
     real(default), intent(in) :: value
   <<msg debug2 implementation>>
   end subroutine msg_debug2_real
 
   module subroutine msg_debug2_complex (area, string, value, color)
     complex(default), intent(in) :: value
   <<msg debug2 implementation>>
   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
        <<debug2 guard>>
     end if
   end subroutine msg_debug2_string
 
 @ %def msg_debug2
 <<msg debug2 implementation>>=
   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
      <<debug2 guard>>
   end if
 @
 <<Diagnostics: public>>=
   public :: debug_active
 <<Diagnostics: sub interfaces>>=
     elemental module function debug_active (area) result (active)
       logical :: active
       integer, intent(in) :: area
     end function debug_active
 <<Diagnostics: procedures>>=
   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
 @
 <<Diagnostics: public>>=
   public :: debug2_active
 <<Diagnostics: sub interfaces>>=
     elemental module function debug2_active (area) result (active)
       logical :: active
       integer, intent(in) :: area
     end function debug2_active
 <<Diagnostics: procedures>>=
   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.
 <<Diagnostics: public>>=
   public :: msg_show_progress
 <<Diagnostics: sub interfaces>>=
     module subroutine msg_show_progress (i_call, n_calls)
       integer, intent(in) :: i_call, n_calls
     end subroutine msg_show_progress
 <<Diagnostics: procedures>>=
   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
 <<Diagnostics: public>>=
   public :: exit
 <<Diagnostics: interfaces>>=
   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:
 <<Diagnostics: public>>=
   public :: msg_banner
 <<Diagnostics: sub interfaces>>=
     module subroutine msg_banner (unit)
       integer, intent(in), optional :: unit
     end subroutine msg_banner
 <<Diagnostics: procedures>>=
   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: <whizard@desy.de>                                           |", 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.
 <<Diagnostics: public>>=
   public :: logging
 <<Diagnostics: variables>>=
   integer, save :: log_unit = -1
   logical, target, save :: logging = .false.
 <<Diagnostics: public>>=
   public :: logfile_init
 <<Diagnostics: sub interfaces>>=
     module subroutine logfile_init (filename)
       type(string_t), intent(in) :: filename
     end subroutine logfile_init
 <<Diagnostics: procedures>>=
   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
 <<Diagnostics: public>>=
   public :: logfile_final
 <<Diagnostics: sub interfaces>>=
     module subroutine logfile_final ()
     end subroutine logfile_final
 <<Diagnostics: procedures>>=
   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.
 <<Diagnostics: public>>=
   public :: logfile_unit
 <<Diagnostics: sub interfaces>>=
     module function logfile_unit (unit, logfile)
       integer :: logfile_unit
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: logfile
     end function logfile_unit
 <<Diagnostics: procedures>>=
   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.
 <<Diagnostics: variables>>=
   integer, save :: expect_total = 0
   integer, save :: expect_failures = 0
 
 @ %def expect_total expect_failures
 <<Diagnostics: public>>=
   public :: expect_record
 <<Diagnostics: sub interfaces>>=
     module subroutine expect_record (success)
       logical, intent(in) :: success
     end subroutine expect_record
 <<Diagnostics: procedures>>=
   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
 <<Diagnostics: public>>=
   public :: expect_clear
 <<Diagnostics: sub interfaces>>=
     module subroutine expect_clear ()
     end subroutine expect_clear
 <<Diagnostics: procedures>>=
   module subroutine expect_clear ()
     expect_total = 0
     expect_failures = 0
   end subroutine expect_clear
 
 @ %def expect_clear
 <<Diagnostics: public>>=
   public :: expect_summary
 <<Diagnostics: sub interfaces>>=
     module subroutine expect_summary (unit, force)
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: force
     end subroutine expect_summary
 <<Diagnostics: procedures>>=
   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.
 <<Diagnostics: public>>=
   public :: int2string
   public :: int2char
   public :: int2fixed
 <<Diagnostics: sub interfaces>>=
     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
 <<Diagnostics: procedures>>=
   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.
 <<Diagnostics: public>>=
   public :: real2string
   public :: real2char
   public :: real2fixed
 <<Diagnostics: interfaces>>=
   interface real2string
      module procedure real2string_list, real2string_fmt
   end interface
   interface real2char
      module procedure real2char_list, real2char_fmt
   end interface
 <<Diagnostics: sub interfaces>>=
     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
 <<Diagnostics: procedures>>=
   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.
 %
 <<CCC Diagnostics: public>>=
    public :: cmplx2string
    public :: cmplx2char
 <<CCC Diagnostics: procedures>>=
    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}
 <<Diagnostics: public>>=
   public :: pacify
 <<Diagnostics: interfaces>>=
   interface pacify
      module procedure pacify_real_default
      module procedure pacify_complex_default
   end interface pacify
 
 <<Diagnostics: sub interfaces>>=
     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
 <<Diagnostics: procedures>>=
   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.
 <<Diagnostics: public>>=
   public :: wo_sigint
   public :: wo_sigterm
   public :: wo_sigxcpu
   public :: wo_sigxfsz
 
 <<Diagnostics: variables>>=
   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..
 <<Diagnostics: public>>=
   public :: mask_term_signals
 <<Diagnostics: sub interfaces>>=
     module subroutine mask_term_signals ()
     end subroutine mask_term_signals
 <<Diagnostics: procedures>>=
   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
 <<Diagnostics: interfaces>>=
   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
 <<Diagnostics: public>>=
   public :: release_term_signals
 <<Diagnostics: sub interfaces>>=
     module subroutine release_term_signals ()
     end subroutine release_term_signals
 <<Diagnostics: procedures>>=
   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
 <<Diagnostics: interfaces>>=
   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
 <<Diagnostics: public>>=
   public :: signal_is_pending
 <<Diagnostics: sub interfaces>>=
     module function signal_is_pending () result (flag)
       logical :: flag
     end function signal_is_pending
 <<Diagnostics: procedures>>=
   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
 <<Diagnostics: public>>=
   public :: terminate_now_if_signal
 <<Diagnostics: sub interfaces>>=
     module subroutine terminate_now_if_signal ()
     end subroutine terminate_now_if_signal
 <<Diagnostics: procedures>>=
   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
 @
 <<Diagnostics: public>>=
   public :: single_event
 <<Diagnostics: variables>>=
   logical :: single_event = .false.
 @
 <<Diagnostics: public>>=
   public :: terminate_now_if_single_event
 <<Diagnostics: sub interfaces>>=
     module subroutine terminate_now_if_single_event ()
     end subroutine terminate_now_if_single_event
 <<Diagnostics: procedures>>=
   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]]>>=
 <<File header>>
 
 module os_interface
 
   use, intrinsic :: iso_c_binding !NODEP!
 
 <<Use strings>>
 
 <<Standard module head>>
 
 <<OS interface: public>>
 
 <<OS interface: types>>
 
 <<OS interface: interfaces>>
 
   interface
 <<OS interface: sub interfaces>>
   end interface
 
 end module os_interface
 @ %def os_interface
 @
 <<[[os_interface_sub.f90]]>>=
 <<File header>>
 
 submodule (os_interface) os_interface_s
 
   use system_defs, only: DLERROR_LEN, ENVVAR_LEN
   use io_units
   use diagnostics
   use system_dependencies
 
 <<Use mpi f08>>
 
+  implicit none
+
 contains
 
 <<OS interface: procedures>>
 
 end submodule os_interface_s
 
 @ %def os_interface_s
 @
 \subsection{Path variables}
 This is a transparent container for storing user-defined path variables.
 <<OS interface: public>>=
   public :: paths_t
 <<OS interface: types>>=
   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
 <<OS interface: public>>=
   public :: paths_init
 <<OS interface: sub interfaces>>=
     module subroutine paths_init (paths)
       type(paths_t), intent(out) :: paths
     end subroutine paths_init
 <<OS interface: procedures>>=
   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]].
 <<OS interface: public>>=
   public :: os_data_t
 <<OS interface: types>>=
   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
    <<OS interface: os data: TBP>>
   end type os_data_t
 
 @ %def os_data_t
 @ Since all are allocatable strings, explicit initialization is
 necessary.
 <<System defs: public parameters>>=
   integer, parameter, public :: ENVVAR_LEN = 1000
 @ %def ENVVAR_LEN
 <<OS interface: os data: TBP>>=
   procedure :: init => os_data_init
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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: $
 <<OS interface: procedures>>=
   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
 <<OS interface: os data: TBP>>=
   procedure :: write => os_data_write
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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
 @
 <<OS interface: os data: TBP>>=
   procedure :: build_latex_file => os_data_build_latex_file
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: dlaccess_t
 <<OS interface: types>>=
   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
    <<OS interface: dlaccess: TBP>>
   end type dlaccess_t
 
 @ %def dlaccess_t
 @ Output.  This is called by the output routine for the process
 library.
 <<OS interface: dlaccess: TBP>>=
   procedure :: write => dlaccess_write
 <<OS interface: sub interfaces>>=
     module subroutine dlaccess_write (object, unit)
       class(dlaccess_t), intent(in) :: object
       integer, intent(in) :: unit
     end subroutine dlaccess_write
 <<OS interface: procedures>>=
   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:
 <<OS interface: interfaces>>=
   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.
 <<System defs: public parameters>>=
   integer, parameter, public :: DLERROR_LEN = 160
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: dlaccess_init
   public :: dlaccess_final
 <<OS interface: dlaccess: TBP>>=
   procedure :: init => dlaccess_init
   procedure :: final => dlaccess_final
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: dlaccess_has_error
 <<OS interface: sub interfaces>>=
    module function dlaccess_has_error (dlaccess) result (flag)
       logical :: flag
       type(dlaccess_t), intent(in) :: dlaccess
     end function dlaccess_has_error
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: dlaccess_get_error
 <<OS interface: sub interfaces>>=
     module function dlaccess_get_error (dlaccess) result (error)
       type(string_t) :: error
       type(dlaccess_t), intent(in) :: dlaccess
     end function dlaccess_get_error
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: dlaccess_get_c_funptr
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: dlaccess_is_open
 <<OS interface: sub interfaces>>=
     module function dlaccess_is_open (dlaccess) result (flag)
       logical :: flag
       type(dlaccess_t), intent(in) :: dlaccess
     end function dlaccess_is_open
 <<OS interface: procedures>>=
   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]].
 <<OS interface: public>>=
   public :: os_system_call
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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
 <<OS interface: interfaces>>=
   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.
 <<OS interface: public>>=
   public :: os_dir_exist
 <<OS interface: sub interfaces>>=
     module function os_dir_exist (name) result (res)
       type(string_t), intent(in) :: name
       logical :: res
     end function os_dir_exist
 <<OS interface: procedures>>=
   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
 @
 <<OS interface: public>>=
   public :: os_file_exist
 <<OS interface: sub interfaces>>=
     module function os_file_exist (name) result (exist)
       type(string_t), intent(in) :: name
       logical :: exist
     end function os_file_exist
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: os_pack_file
   public :: os_unpack_file
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: os_compile_shared
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: os_link_shared
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: os_link_static
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: os_get_dlname
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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.
 <<OS interface: public>>=
   public :: openmp_set_num_threads_verbose
 <<OS interface: sub interfaces>>=
     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
 <<OS interface: procedures>>=
   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]].
 <<OS interface: public>>=
   public :: mpi_set_logging
 <<OS interface: sub interfaces>>=
     module subroutine mpi_set_logging (mpi_logging)
       logical, intent(in) :: mpi_logging
     end subroutine mpi_set_logging
 <<OS interface: procedures>>=
   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]].
 <<OS interface: public>>=
   public :: mpi_get_comm_id
 <<OS interface: sub interfaces>>=
     module subroutine mpi_get_comm_id (n_size, rank)
       integer, intent(out) :: n_size
       integer, intent(out) :: rank
     end subroutine mpi_get_comm_id
 <<OS interface: procedures>>=
   module subroutine mpi_get_comm_id (n_size, rank)
     integer, intent(out) :: n_size
     integer, intent(out) :: rank
     n_size = 1
     rank = 0
   <<OS interface: mpi get comm id>>
   end subroutine mpi_get_comm_id
 
 @ %def mpi_get_comm_id
 <<OS interface: mpi get comm id>>=
 @
 <<MPI: OS interface: mpi get comm id>>=
   call MPI_Comm_size (MPI_COMM_WORLD, n_size)
   call MPI_Comm_rank (MPI_COMM_WORLD, rank)
 @
 <<OS interface: public>>=
   public :: mpi_is_comm_master
 <<OS interface: sub interfaces>>=
     module function mpi_is_comm_master () result (flag)
       logical :: flag
     end function mpi_is_comm_master
 <<OS interface: procedures>>=
   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]]>>=
 <<File header>>
 
 module os_interface_ut
   use unit_tests
   use os_interface_uti
 
 <<Standard module head>>
 
 <<OS interface: public test>>
 
 contains
 
 <<OS interface: test driver>>
 
 end module os_interface_ut
 @ %def os_interface_ut
 @
 <<[[os_interface_uti.f90]]>>=
 <<File header>>
 
 module os_interface_uti
 
   use, intrinsic :: iso_c_binding !NODEP!
 
 <<Use strings>>
   use io_units
 
   use os_interface
 
 <<Standard module head>>
 
 <<OS interface: test declarations>>
 
 contains
 
 <<OS interface: tests>>
 
 end module os_interface_uti
 @ %def os_interface_ut
 @ API: driver for the unit tests below.
 <<OS interface: public test>>=
   public :: os_interface_test
 <<OS interface: test driver>>=
   subroutine os_interface_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<OS interface: execute tests>>
   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.
 <<OS interface: execute tests>>=
   call test (os_interface_1, "os_interface_1", &
        "check OS interface routines", &
        u, results)
 <<OS interface: test declarations>>=
   public :: os_interface_1
 <<OS interface: tests>>=
   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]]>>=
 <<File header>>
 
 module formats
 
   use, intrinsic :: iso_c_binding
 
 <<Use kinds>>
 <<Use strings>>
 
 <<Standard module head>>
 
 <<Formats: public>>
 
 <<Formats: parameters>>
 
 <<Formats: types>>
 
 <<Formats: interfaces>>
 
   interface
 <<Formats: sub interfaces>>
   end interface
 
 end module formats
 @ %def formats
 @
 <<[[formats_sub.f90]]>>=
 <<File header>>
 
 submodule (formats) formats_s
 
   use io_units
   use diagnostics
 
+  implicit none
+
 contains
 
 <<Formats: procedures>>
 
 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.
 <<Formats: parameters>>=
   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.
 <<Formats: public>>=
   public :: sprintf_arg_t
 <<Formats: types>>=
   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
 <<Formats: public>>=
   public :: sprintf_arg_init
 <<Formats: interfaces>>=
   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
 
 <<Formats: sub interfaces>>=
     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
 <<Formats: procedures>>=
   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
 <<Formats: procedures>>=
   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.
 <<Formats: procedures>>=
   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
 <<Formats: procedures>>=
   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.
 <<Formats: types>>=
   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
 <<Formats: procedures>>=
   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
 <<Formats: procedures>>=
   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:
 <<Formats: procedures>>=
   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
 <<Formats: procedures>>=
   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:
 <<Formats: interfaces>>=
 <<sprintf interfaces>>
 
 @
 \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.
 <<Formats: procedures>>=
   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}
 <<Formats: public>>=
   public :: sprintf
 <<Formats: sub interfaces>>=
     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
 <<Formats: procedures>>=
   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]]>>=
 <<File header>>
 
 module formats_ut
   use unit_tests
   use formats_uti
 
 <<Standard module head>>
 
 <<Formats: public test>>
 
 contains
 
 <<Formats: test driver>>
 
 end module formats_ut
 @ %def formats_ut
 @
 <<[[formats_uti.f90]]>>=
 <<File header>>
 
 module formats_uti
 
 <<Use kinds>>
 <<Use strings>>
 
   use formats
 
 <<Standard module head>>
 
 <<Formats: test declarations>>
 
 <<Formats: test types>>
 
 contains
 
 <<Formats: tests>>
 
 end module formats_uti
 @ %def formats_ut
 @ API: driver for the unit tests below.
 <<Formats: public test>>=
   public :: format_test
 <<Formats: test driver>>=
   subroutine format_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Formats: execute tests>>
   end subroutine format_test
 
 @ %def format_test
 <<Formats: execute tests>>=
   call test (format_1, "format_1", &
        "check formatting routines", &
        u, results)
 <<Formats: test declarations>>=
   public :: format_1
 <<Formats: tests>>=
   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]]>>=
 <<File header>>
 
 module cputime
 
 <<Use kinds>>
 <<Use strings>>
 
 <<Standard module head>>
 
 <<CPU time: public>>
 
 <<CPU time: types>>
 
 <<CPU time: interfaces>>
 
   interface
 <<CPU time: sub interfaces>>
   end interface
 
 end module cputime
 @ %def cputime
 <<[[cputime_sub.f90]]>>=
 <<File header>>
 
 submodule (cputime) cputime_s
 
   use io_units
   use diagnostics
 
+  implicit none
+
 contains
 
 <<CPU time: procedures>>
 
 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.
 <<CPU time: public>>=
   public :: time_t
 <<CPU time: types>>=
   type :: time_t
      private
      logical :: known = .false.
      real :: value = 0
    contains
    <<CPU time: time: TBP>>
   end type time_t
 
 @ %def time_t
 <<CPU time: time: TBP>>=
   procedure :: write => time_write
 <<CPU time: sub interfaces>>=
     module subroutine time_write (object, unit)
       class(time_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine time_write
 <<CPU time: procedures>>=
   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
 <<CPU time: time: TBP>>=
   procedure :: set_current => time_set_current
 <<CPU time: sub interfaces>>=
     module subroutine time_set_current (time)
       class(time_t), intent(out) :: time
     end subroutine time_set_current
 <<CPU time: procedures>>=
   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.
 <<CPU time: public>>=
   public :: assignment(=)
 <<CPU time: interfaces>>=
   interface assignment(=)
     module procedure real_assign_time
     module procedure real_default_assign_time
   end interface
 
 <<CPU time: sub interfaces>>=
     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
 <<CPU time: procedures>>=
   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.
 <<CPU time: time: TBP>>=
   generic :: assignment(=) => time_assign_from_integer, time_assign_from_real
   procedure, private :: time_assign_from_integer
   procedure, private :: time_assign_from_real
 <<CPU time: sub interfaces>>=
     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
 <<CPU time: procedures>>=
   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.
 <<CPU time: time: TBP>>=
   generic :: operator(-) => subtract_times
   generic :: operator(+) => add_times
   procedure, private :: subtract_times
   procedure, private :: add_times
 <<CPU time: sub interfaces>>=
     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
 <<CPU time: procedures>>=
   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:
 <<CPU time: time: TBP>>=
   procedure :: is_known => time_is_known
 <<CPU time: sub interfaces>>=
     module function time_is_known (time) result (flag)
       class(time_t), intent(in) :: time
       logical :: flag
     end function time_is_known
 <<CPU time: procedures>>=
   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.
 <<CPU time: time: TBP>>=
   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
 <<CPU time: sub interfaces>>=
     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
 <<CPU time: procedures>>=
   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.
 <<CPU time: time: TBP>>=
   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
 <<CPU time: sub interfaces>>=
     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
 <<CPU time: procedures>>=
   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.
 <<CPU time: public>>=
   public :: timer_t
 <<CPU time: types>>=
   type, extends (time_t) :: timer_t
      private
      logical :: running = .false.
      type(time_t) :: t1, t2
    contains
    <<CPU time: timer: TBP>>
   end type timer_t
 
 @ %def timer_t
 @ Output.  If the timer is running, we indicate this, otherwise write
 just the result.
 <<CPU time: timer: TBP>>=
   procedure :: write => timer_write
 <<CPU time: sub interfaces>>=
     module subroutine timer_write (object, unit)
       class(timer_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine timer_write
 <<CPU time: procedures>>=
   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.
 <<CPU time: timer: TBP>>=
   procedure :: start => timer_start
 <<CPU time: sub interfaces>>=
     module subroutine timer_start (timer)
       class(timer_t), intent(out) :: timer
     end subroutine timer_start
 <<CPU time: procedures>>=
   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.
 <<CPU time: timer: TBP>>=
   procedure :: restart => timer_restart
 <<CPU time: sub interfaces>>=
     module subroutine timer_restart (timer)
       class(timer_t), intent(inout) :: timer
     end subroutine timer_restart
 <<CPU time: procedures>>=
   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.
 <<CPU time: timer: TBP>>=
   procedure :: stop => timer_stop
 <<CPU time: sub interfaces>>=
     module subroutine timer_stop (timer)
       class(timer_t), intent(inout) :: timer
     end subroutine timer_stop
 <<CPU time: procedures>>=
   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)
 <<CPU time: timer: TBP>>=
   procedure :: set_test_time1 => timer_set_test_time1
   procedure :: set_test_time2 => timer_set_test_time2
 <<CPU time: sub interfaces>>=
     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
 <<CPU time: procedures>>=
   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.
 <<CPU time: timer: TBP>>=
   procedure :: evaluate => timer_evaluate
 <<CPU time: sub interfaces>>=
     module subroutine timer_evaluate (timer)
       class(timer_t), intent(inout) :: timer
     end subroutine timer_evaluate
 <<CPU time: procedures>>=
   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]]>>=
 <<File header>>
 
 module cputime_ut
   use unit_tests
   use cputime_uti
 
 <<Standard module head>>
 
 <<CPU time: public test>>
 
 contains
 
 <<CPU time: test driver>>
 
 end module cputime_ut
 @ %def cputime_ut
 @
 <<[[cputime_uti.f90]]>>=
 <<File header>>
 
 module cputime_uti
 
 <<Use strings>>
 
   use cputime
 
 <<Standard module head>>
 
 <<CPU time: test declarations>>
 
 contains
 
 <<CPU time: tests>>
 
 end module cputime_uti
 @ %def cputime_ut
 @ API: driver for the unit tests below.
 <<CPU time: public test>>=
   public :: cputime_test
 <<CPU time: test driver>>=
   subroutine cputime_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<CPU time: execute tests>>
   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.
 <<CPU time: execute tests>>=
   call test (cputime_1, "cputime_1", &
        "time operations", &
        u, results)
 <<CPU time: test declarations>>=
   public :: cputime_1
 <<CPU time: tests>>=
   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.
 <<CPU time: execute tests>>=
   call test (cputime_2, "cputime_2", &
        "timer", &
        u, results)
 <<CPU time: test declarations>>=
   public :: cputime_2
 <<CPU time: tests>>=
   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 <kilian@physik.uni-siegen.de>
 #     Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
 #     Juergen Reuter <juergen.reuter@desy.de>
 #     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/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 <kilian@physik.uni-siegen.de>
 #     Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
 #     Juergen Reuter <juergen.reuter@desy.de>
 #     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
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]]>>=
 <<File header>>
 
 module bytes
 
   use kinds, only: i8, i32, i64
-  use io_units
 
 <<Standard module head>>
 
 <<Bytes: public>>
 
 <<Bytes: types>>
 
 <<Bytes: parameters>>
 
 <<Bytes: interfaces>>
 
+  interface
+<<Bytes: sub interfaces>>
+  end interface
+
+end module bytes
+@ %def bytes
+@
+<<[[bytes_sub.f90]]>>=
+<<File header>>
+
+submodule (bytes) bytes_s
+
+  use io_units
+
 contains
 
 <<Bytes: procedures>>
 
-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.
 <<Bytes: public>>=
   public :: byte_t
 <<Bytes: types>>=
   type :: byte_t
      private
      integer(i8) :: i
   end type byte_t
 
 @ %def byte
 <<Bytes: public>>=
   public :: byte_zero
 <<Bytes: parameters>>=
   type(byte_t), parameter :: byte_zero = byte_t (0_i8)
 
 @ %def byte_zero
 @ Set a byte from 8-bit integer:
 <<Bytes: public>>=
   public :: assignment(=)
 <<Bytes: interfaces>>=
   interface assignment(=)
      module procedure set_byte_from_i8
   end interface
 @ %def =
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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.
 <<Bytes: public>>=
   public :: byte_write
 <<Bytes: interfaces>>=
   interface byte_write
      module procedure byte_write_unit, byte_write_string
   end interface
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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
+<<Bytes: sub interfaces>>=
+    module subroutine byte_write_string (b, s)
+      type(byte_t), intent(in) :: b
+      character(len=2), intent(inout) :: s
+    end subroutine byte_write_string
 <<Bytes: procedures>>=
-  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.
 <<Bytes: public>>=
   public :: word32_t
 <<Bytes: types>>=
   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
 <<Bytes: interfaces>>=
   interface assignment(=)
      module procedure word32_set_from_i32
      module procedure word32_set_from_byte
   end interface
 @ %def =
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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.
 <<Bytes: interfaces>>=
   interface assignment(=)
      module procedure i32_from_word32
   end interface
 @ %def =
+<<Bytes: sub interfaces>>=
+    module subroutine i32_from_word32 (i, w)
+      integer(i32), intent(out) :: i
+      type(word32_t), intent(in) :: w
+    end subroutine i32_from_word32
 <<Bytes: procedures>>=
-  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.
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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
 <<Bytes: public>>=
   public :: word32_empty, word32_filled, word32_fill
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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.)
 <<Bytes: public>>=
   public :: word32_append_byte
+<<Bytes: sub interfaces>>=
+    module subroutine word32_append_byte (w, b)
+      type(word32_t), intent(inout) :: w
+      type(byte_t), intent(in) :: b
+    end subroutine word32_append_byte
 <<Bytes: procedures>>=
-  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.
 <<Bytes: public>>=
   public :: byte_from_word32
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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.
 <<Bytes: public>>=
   public :: word32_write
 <<Bytes: interfaces>>=
   interface word32_write
      module procedure word32_write_unit
   end interface
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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.
 <<Bytes: public>>=
   public :: not, ior, ieor, iand, ishft, ishftc
 <<Bytes: interfaces>>=
   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
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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.
 <<Bytes: public>>=
   public :: operator(+)
 <<Bytes: interfaces>>=
   interface operator(+)
      module procedure word_add
      module procedure word_add_i8
      module procedure word_add_i32
   end interface
 @ %def +
 @
+<<Bytes: sub interfaces>>=
+  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
 <<Bytes: procedures>>=
-  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.
 <<Bytes: public>>=
   public :: word64_t
 <<Bytes: types>>=
   type :: word64_t
      private
      integer(i64) :: i
   end type word64_t
 
 @ %def word64
 @ Set a 64 bit word:
 <<Bytes: interfaces>>=
   interface assignment(=)
      module procedure word64_set_from_i64
      module procedure word64_set_from_word32
   end interface
 @ %def =
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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:
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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.
 <<Bytes: public>>=
   public :: byte_from_word64, word32_from_word64
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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.
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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.
 <<Bytes: public>>=
   public :: word64_write
 <<Bytes: interfaces>>=
   interface word64_write
      module procedure word64_write_unit
   end interface
+<<Bytes: sub interfaces>>=
+    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
 <<Bytes: procedures>>=
-  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]]>>=
 <<File header>>
 
 module hashes
 
   use kinds, only: i8, i32
-  use bytes
 
 <<Standard module head>>
 
 <<Hashes: public>>
 
+  interface
+<<Hashes: sub interfaces>>
+  end interface
+
+end module hashes
+@ %def hashes
+@
+<<[[hashes_sub.f90]]>>=
+<<File header>>
+
+submodule (hashes) hashes_s
+
+  use bytes
+
 contains
 
 <<Hashes: procedures>>
 
-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.
 <<Hashes: public>>=
   public :: hash
+<<Hashes: sub interfaces>>=
+    module function hash (key) result (hashval)
+      integer(i32) :: hashval
+      integer(i8), dimension(:), intent(in) :: key
+    end function hash
 <<Hashes: procedures>>=
-  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:
 <<Hashtables: types>>=
   type :: hash_data_t
      integer :: i
   end type hash_data_t
 
 @ %def hash_data_t
 @ Associated methods:
 <<Hashtables: procedures>>=
   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.
 <<Hashtables: types>>=
   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.
 <<Hashtables: types>>=
   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.
 <<Hashtables: procedures>>=
   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.
 <<Hashtables: procedures>>=
   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.
 <<Hashtables: procedures>>=
   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.
 <<Hashtables: procedures>>=
   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.
 <<Hashtables: procedures>>=
   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.
 <<Hashtables: procedures>>=
   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.
 <<Hashtables: procedures>>=
   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
 <<Hashtables: procedures>>=
   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
 <<Hashtables: public>>=
   public :: hashtable_test
 <<Hashtables: procedures>>=
   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]]>>=
 <<File header>>
 
 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
 
 <<Standard module head>>
 
 <<MD5: public>>
 
 <<MD5: types>>
 
-<<MD5: variables>>
-
 <<MD5: interfaces>>
 
+  interface
+<<MD5: sub interfaces>>
+  end interface
+
+end module md5
+@ %def md5
+@
+<<[[md5_sub.f90]]>>=
+<<File header>>
+
+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
+
+<<MD5: variables>>
+
 contains
 
 <<MD5: procedures>>
 
-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.
 <<MD5: types>>=
   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:
 <<MD5: procedures>>=
   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.
 <<MD5: procedures>>=
   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.
 <<MD5: interfaces>>=
   interface block_write
      module procedure block_write_unit
   end interface
+<<MD5: sub interfaces>>=
+    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
 <<MD5: procedures>>=
-  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.
 <<MD5: types>>=
   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
 <<MD5: procedures>>=
   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
 <<MD5: procedures>>=
   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.
 <<MD5: procedures>>=
   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.
 <<MD5: procedures>>=
   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.
 <<MD5: procedures>>=
   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.
 <<MD5: procedures>>=
   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.
 <<MD5: procedures>>=
   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.
 <<MD5: procedures>>=
   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.
 <<MD5: procedures>>=
   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.)
 <<MD5: procedures>>=
   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.
 <<MD5: interfaces>>=
   interface message_write
      module procedure message_write_unit
   end interface
+<<MD5: sub interfaces>>=
+    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
 <<MD5: procedures>>=
-  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:
 <<MD5: procedures>>=
   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:
 <<MD5: variables>>=
   type(word32_t), dimension(64), save :: t
   logical, save :: table_initialized = .false.
 @ %def t table_initialized
 <<MD5: procedures>>=
   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.
 <<MD5: procedures>>=
   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.
 <<MD5: procedures>>=
   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.
 <<MD5: procedures>>=
   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
   <<MD5: Internal subroutine transform>>
   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.
 <<MD5: Internal subroutine transform>>=
   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}
 <<MD5: public>>=
   public :: md5sum
 <<MD5: interfaces>>=
   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
+<<MD5: sub interfaces>>=
+    module function md5sum_from_string (s) result (digest)
+      character(len=*), intent(in) :: s
+      character(len=32) :: digest
+    end function md5sum_from_string
 <<MD5: procedures>>=
-  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.
+<<MD5: sub interfaces>>=
+    module function md5sum_from_unit (u) result (digest)
+      integer, intent(in) :: u
+      character(len=32) :: digest
+    end function md5sum_from_unit
 <<MD5: procedures>>=
-  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]]>>=
 <<File header>>
 
 module md5_ut
   use unit_tests
   use md5_uti
 
 <<Standard module head>>
 
 <<MD5: public test>>
 
 contains
 
 <<MD5: test driver>>
 
 end module md5_ut
 @ %def md5_ut
 @
 <<[[md5_uti.f90]]>>=
 <<File header>>
 
 module md5_uti
 
   use diagnostics
 
   use md5
 
 <<Standard module head>>
 
 <<MD5: test declarations>>
 
 contains
 
 <<MD5: tests>>
 
 end module md5_uti
 @ %def md5_ut
 @ API: driver for the unit tests below.
 <<MD5: public test>>=
   public :: md5_test
 <<MD5: test driver>>=
   subroutine md5_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<MD5: execute tests>>
   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.
 <<MD5: execute tests>>=
   call test (md5_1, "md5_1", &
        "check MD5 sums", &
        u, results)
 <<MD5: test declarations>>=
   public :: md5_1
 <<MD5: tests>>=
   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]]>>=
 <<File header>>
 
 module permutations
 
   use kinds, only: TC
 
 <<Standard module head>>
 
 <<Permutations: public>>
 
 <<Permutations: types>>
 
 <<Permutations: interfaces>>
 
+  interface
+<<Permutations: sub interfaces>>
+  end interface
+
+end module permutations
+@ %def permutations
+@
+<<[[permutations_sub.f90]]>>=
+<<File header>>
+
+submodule (permutations) permutations_s
+
+<<Permutations: variables>>
+
 contains
 
 <<Permutations: procedures>>
 
-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.
 <<Permutations: public>>=
   public :: permutation_t
 <<Permutations: types>>=
   type :: permutation_t
      private
      integer, dimension(:), allocatable :: p
   end type permutation_t
 
 @ %def permutation
 @
 Initialize with the identity permutation.
 <<Permutations: public>>=
   public :: permutation_init
   public :: permutation_final
+<<Permutations: sub interfaces>>=
+    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
 <<Permutations: procedures>>=
-  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:
 <<Permutations: public>>=
   public :: permutation_write
+<<Permutations: sub interfaces>>=
+    module subroutine permutation_write (p, u)
+      type(permutation_t), intent (in) :: p
+      integer, intent(in) :: u
+    end subroutine permutation_write
 <<Permutations: procedures>>=
-  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:
 <<Permutations: public>>=
   public :: permutation_size
+<<Permutations: sub interfaces>>=
+    elemental module function permutation_size (perm) result (s)
+      type(permutation_t), intent(in) :: perm
+      integer :: s
+    end function permutation_size
 <<Permutations: procedures>>=
-  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.
 <<Permutations: public>>=
   public :: permute
+<<Permutations: sub interfaces>>=
+    elemental module function permute (i, p) result (j)
+      integer, intent(in) :: i
+      type(permutation_t), intent(in) :: p
+      integer :: j
+    end function permute
 <<Permutations: procedures>>=
-  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.
 <<Permutations: public>>=
   public :: permutation_ok
+<<Permutations: sub interfaces>>=
+    elemental module function permutation_ok (perm) result (ok)
+      type(permutation_t), intent(in) :: perm
+      logical :: ok
+    end function permutation_ok
 <<Permutations: procedures>>=
-  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.
 <<Permutations: public>>=
   public :: permutation_find
+<<Permutations: sub interfaces>>=
+    module subroutine permutation_find (perm, a1, a2)
+      type(permutation_t), intent(inout) :: perm
+      integer, dimension(:), intent(in) :: a1, a2
+    end subroutine permutation_find
 <<Permutations: procedures>>=
-  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.
 <<Permutations: public>>=
   public :: permutation_array_make
+<<Permutations: sub interfaces>>=
+    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
 <<Permutations: procedures>>=
-  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).
 <<Permutations: procedures>>=
   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:
 <<Permutations: public>>=
   public :: factorial
+<<Permutations: sub interfaces>>=
+    elemental module function factorial (n) result (f)
+      integer, intent(in) :: n
+      integer :: f
+    end function factorial
 <<Permutations: procedures>>=
-  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.)
 <<Permutations: public>>=
   public :: tc_permute
+<<Permutations: sub interfaces>>=
+    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
 <<Permutations: procedures>>=
-  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.
 <<Permutations: public>>=
   public :: tc_decay_level
 <<Permutations: interfaces>>=
   interface tc_decay_level
      module procedure decay_level_simple
      module procedure decay_level_complement
   end interface
 @ %def decay_level
+<<Permutations: sub interfaces>>=
+    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
 <<Permutations: procedures>>=
-  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]]>>=
 <<File header>>
 
 module sorting
 
 <<Use kinds>>
   use diagnostics
 
 <<Standard module head>>
 
 <<Sorting: public>>
 
 <<Sorting: interfaces>>
 
 contains
 
 <<Sorting: procedures>>
 
 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.
 <<Sorting: public>>=
   public :: sort
   public :: sort_abs
 <<Sorting: interfaces>>=
   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.
 <<Sorting: procedures>>=
   function sort_int (val_in) result (val)
     integer, dimension(:), intent(in) :: val_in
     integer, dimension(size(val_in)) :: val
   <<Sorting: sort>>
   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
   <<Sorting: sort>>
   end function sort_real
 
   function sort_int_abs (val_in) result (val)
     integer, dimension(:), intent(in) :: val_in
     integer, dimension(size(val_in)) :: val
   <<Sorting: sort abs>>
   end function sort_int_abs
 
 @ %def sort_int sort_real sort_int_abs
 <<Sorting: sort>>=
   val = val_in( order (val_in) )
 <<Sorting: sort abs>>=
   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.
 <<Sorting: public>>=
   public :: order
   public :: order_abs
 <<Sorting: interfaces>>=
   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
 <<Sorting: procedures>>=
   function order_int (val) result (idx)
     integer, dimension(:), intent(in) :: val
     integer, dimension(size(val)) :: idx
   <<Sorting: order>>
   end function order_int
 
   function order_real (val) result (idx)
     real(default), dimension(:), intent(in) :: val
     integer, dimension(size(val)) :: idx
   <<Sorting: order>>
   end function order_real
 
   function order_int_abs (val) result (idx)
     integer, dimension(:), intent(in) :: val
     integer, dimension(size(val)) :: idx
   <<Sorting: order abs>>
   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.
 <<Sorting: order>>=
 <<Sorting: order1>>
         call merge (idx(b1:e2), idx(b1:e1), idx(b2:e2), val)
 <<Sorting: order2>>
 @
 <<Sorting: order abs>>=
 <<Sorting: order1>>
         call merge_abs (idx(b1:e2), idx(b1:e1), idx(b2:e2), val)
 <<Sorting: order2>>
 @
 <<Sorting: order1>>=
   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)
 @
 <<Sorting: order2>>=
      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.
 <<Sorting: interfaces>>=
   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
 <<Sorting: procedures>>=
   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
   <<Sorting: merge>>
   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
   <<Sorting: merge>>
   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
   <<Sorting: merge abs>>
   end subroutine merge_int_abs
 
 @ %def merge_int merge_real merge_int_abs
 <<Sorting: merge>>=
 <<Sorting: merge1>>
      if (val(src1(i1)) <= val(src2(i2))) then
 <<Sorting: merge2>>
 @ 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.
 <<Sorting: merge abs>>=
 <<Sorting: merge1>>
      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
 <<Sorting: merge2>>
 @
 <<Sorting: merge1>>=
   integer :: i1, i2, i
   i1 = 1
   i2 = 1
   do i = 1, size (tmp)
 @
 <<Sorting: merge2>>=
         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]]>>=
 <<File header>>
 
 module sorting_ut
   use unit_tests
   use sorting_uti
 
 <<Standard module head>>
 
 <<Sorting: public test>>
 
 contains
 
 <<Sorting: test driver>>
 
 end module sorting_ut
 @ %def sorting_ut
 @
 <<[[sorting_uti.f90]]>>=
 <<File header>>
 
 module sorting_uti
 
 <<Use kinds>>
 
   use sorting
 
 <<Standard module head>>
 
 <<Sorting: test declarations>>
 
 contains
 
 <<Sorting: tests>>
 
 end module sorting_uti
 @ %def sorting_ut
 @ API: driver for the unit tests below.
 <<Sorting: public test>>=
   public :: sorting_test
 <<Sorting: test driver>>=
   subroutine sorting_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Sorting: execute tests>>
   end subroutine sorting_test
 
 @ %def sorting_test
 @ This checks whether the sorting routine works correctly.
 <<Sorting: execute tests>>=
   call test (sorting_1, "sorting_1", &
        "check sorting routines", &
        u, results)
 <<Sorting: test declarations>>=
   public :: sorting_1
 <<Sorting: tests>>=
   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]]>>=
 <<File header>>
 
 module grids
 
 <<Use kinds>>
   use constants, only: zero, one, tiny_07
   use io_units
   use format_defs, only: FMT_16
   use diagnostics
 <<Use mpi f08>>
 
 <<Standard module head>>
 
 <<Grids: public>>
 
 <<Grids: parameters>>
 
 <<Grids: types>>
 
 contains
 
 <<Grids: procedures>>
 
 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}
 <<Grids: public>>=
   public :: grid_t
 <<Grids: types>>=
   type :: grid_t
      private
      real(default), dimension(:), allocatable :: values
      integer, dimension(:), allocatable :: points
   contains
    <<Grids: grid: TBP>>
   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.
 <<Grids: grid: TBP>>=
   generic :: init => init_base, init_simple
   procedure :: init_base => grid_init_base
   procedure :: init_simple => grid_init_simple
 <<Grids: procedures>>=
   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
 <<Grids: procedures>>=
   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)
 <<Grids: grid: TBP>>=
   procedure :: set_values => grid_set_values
 <<Grids: procedures>>=
   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
 <<Grids: parameters>>=
   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.
 <<Grids: grid: TBP>>=
   procedure :: final => grid_final
 <<Grids: procedures>>=
   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.
 <<Grids: grid: TBP>>=
   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
 <<Grids: procedures>>=
   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
 <<Grids: procedures>>=
   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})$.
 <<Grids: grid: TBP>>=
   procedure :: get_segment => grid_get_segment
 <<Grids: procedures>>=
   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}
 <<Grids: grid: TBP>>=
   procedure :: get_index => grid_get_index
 <<Grids: procedures>>=
   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\}$.
 <<Grids: grid: TBP>>=
   procedure :: update_maxima => grid_update_maxima
 <<Grids: procedures>>=
   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}.
 <<Grids: grid: TBP>>=
   procedure :: get_maximum_in_3d => grid_get_maximum_in_3d
 <<Grids: procedures>>=
   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
 @
 <<Grids: grid: TBP>>=
   procedure :: is_non_zero_everywhere => grid_is_non_zero_everywhere
 <<Grids: procedures>>=
   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.
 <<Grids: grid: TBP>>=
   procedure :: has_non_zero_entries => grid_has_non_zero_entries
 <<Grids: procedures>>=
   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.
 <<MPI: Grids: grid: TBP>>=
   procedure :: mpi_reduce => grid_mpi_reduce
 <<MPI: Grids: procedures>>=
   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}
 
 <<Grids: grid: TBP>>=
   procedure :: write => grid_write
 <<Grids: procedures>>=
   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
 @
 <<Grids: grid: TBP>>=
   procedure :: compute_and_write_mean_and_max => &
        grid_compute_and_write_mean_and_max
 <<Grids: procedures>>=
   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
 @
 <<Grids: grid: TBP>>=
   procedure :: save_to_file => grid_save_to_file
 <<Grids: procedures>>=
   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
 @
 <<Grids: parameters>>=
   character(len=*), parameter :: DEFAULT_OUTPUT_PRECISION = FMT_16
 @ %def DEFAULT_OUTPUT_PRECISION
 @
 <<Grids: public>>=
   public :: verify_points_for_grid
 <<Grids: procedures>>=
   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.
 <<Grids: procedures>>=
   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
 @
 <<Grids: grid: TBP>>=
   procedure :: load_from_file => grid_load_from_file
 <<Grids: procedures>>=
   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]]>>=
 <<File header>>
 
 module grids_ut
   use unit_tests
   use grids_uti
 
 <<Standard module head>>
 
 <<Grids: public test>>
 
 contains
 
 <<Grids: test driver>>
 
 end module grids_ut
 @ %def grids_ut
 @
 <<[[grids_uti.f90]]>>=
 <<File header>>
 
 module grids_uti
 
 <<Use kinds>>
   use constants, only: zero, one, two, three, four, tiny_07
   use file_utils, only: delete_file
   use numeric_utils
 
   use grids
 
 <<Standard module head>>
 
 <<Grids: test declarations>>
 
 contains
 
 <<Grids: tests>>
 
 end module grids_uti
 @ %def grids_ut
 @ API: driver for the unit tests below.
 <<Grids: public test>>=
   public :: grids_test
 <<Grids: test driver>>=
   subroutine grids_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Grids: execute tests>>
   end subroutine grids_test
 
 @ %def grids_test
 @
 \subsubsection{Test Index Function}
 <<Grids: execute tests>>=
   call test(grids_1, "grids_1", &
        "Test Index Function", u, results)
 <<Grids: test declarations>>=
   public :: grids_1
 <<Grids: tests>>=
   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}
 <<Grids: execute tests>>=
   call test(grids_2, "grids_2", &
             "Saving and Loading", u, results)
 <<Grids: test declarations>>=
   public :: grids_2
 <<Grids: tests>>=
   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}
 <<Grids: execute tests>>=
   call test(grids_3, "grids_3", &
             "Get Segments", u, results)
 <<Grids: test declarations>>=
   public :: grids_3
 <<Grids: tests>>=
   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}
 <<Grids: execute tests>>=
   call test(grids_4, "grids_4", &
             "Update Maxima", u, results)
 <<Grids: test declarations>>=
   public :: grids_4
 <<Grids: tests>>=
   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}
 <<Grids: execute tests>>=
   call test(grids_5, "grids_5", &
             "Finding and checking", u, results)
 <<Grids: test declarations>>=
   public :: grids_5
 <<Grids: tests>>=
   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]]>>=
 <<File header>>
 
 module solver
 
 <<Use kinds>>
   use constants, only: tiny_10
   use numeric_utils
   use diagnostics
 
 <<Standard module head>>
 
 <<solver: public>>
 
 <<solver: parameters>>
 
 <<solver: types>>
 
 <<solver: interfaces>>
 
 contains
 
 <<solver: procedures>>
 
 end module solver
 @ %def solver
 @
 <<solver: public>>=
   public :: solver_function_t
 <<solver: types>>=
   type, abstract :: solver_function_t
   contains
     procedure(solver_function_evaluate), deferred :: evaluate
   end type solver_function_t
 
 @ %def solver_function_t
 @
 <<solver: interfaces>>=
   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
 @
 <<solver: public>>=
   public :: solve_secant
 <<solver: procedures>>=
   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) )
        <<Exit if close to zero and handle exceptions>>
        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
 <<Exit if close to zero and handle exceptions>>=
 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]].
 <<solver: public>>=
   public :: solve_interval
 <<solver: procedures>>=
   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
 @
 <<solver: public>>=
   public :: solve_qgaus
 <<solver: procedures>>=
   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
 @
 <<solver: parameters>>=
   real(default), parameter, public :: DEFAULT_PRECISION = tiny_10
 @ %def name
 @
 <<solver: parameters>>=
   integer, parameter :: MAX_TRIES = 10000
 @ %def MAX_TRIES
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[solver_ut.f90]]>>=
 <<File header>>
 
 module solver_ut
   use unit_tests
   use solver_uti
 
 <<Standard module head>>
 
 <<solver: public test>>
 
 contains
 
 <<solver: test driver>>
 
 end module solver_ut
 @ %def solver_ut
 @
 <<[[solver_uti.f90]]>>=
 <<File header>>
 
 module solver_uti
 
 <<Use kinds>>
   use constants, only: zero, one, two
   use numeric_utils
 
   use solver
 
 <<Standard module head>>
 
 <<solver: test declarations>>
 
 <<solver: test types>>
 
 contains
 
 <<solver: tests>>
 
 <<solver: test auxiliary>>
 
 end module solver_uti
 @ %def solver_ut
 @ API: driver for the unit tests below.
 <<solver: public test>>=
   public :: solver_test
 <<solver: test driver>>=
   subroutine solver_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<solver: execute tests>>
   end subroutine solver_test
 
 @ %def solver_test
 @
 \subsubsection{Test functions}
 <<solver: test types>>=
   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
 @
 <<solver: test types>>=
   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
 @
 <<solver: test types>>=
   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
 @
 <<solver: test types>>=
   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
 @
 <<solver: test auxiliary>>=
   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}
 <<solver: execute tests>>=
   call test(solver_1, "solver_1", &
             "Solve trivial functions", u, results)
 <<solver: test declarations>>=
   public :: solver_1
 <<solver: tests>>=
   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
 @