Initial working version

.gitignore

+*.la
+*.lo
+*.o
+.deps
+.dirstamp
+.libs
+Makefile
+Makefile.in
+aclocal.m4
+ar-lib
+autom4te.cache/
+compile
+config.guess
+config.h
+config.h.in
+config.h.in~
+config.log
+config.status
+config.sub
+configure
+depcomp
+install-sh
+libtool
+ltmain.sh
+m4/
+missing
+stamp-h1
+ftimings-*.pc
+ftimings_test
+ftimings.mod

Makefile.am

+AUTOMAKE_OPTIONS = subdir-objects
+ACLOCAL_AMFLAGS = ${ACLOCAL_FLAGS} -I m4
+AM_CFLAGS = -DPACKAGE_FILESDIR=\"$(filesdir)\" \
+	-O2 --pedantic-error -ansi -Wall --std=gnu99 \
+	$(GSL_CFLAGS) $(CFLAG_VISIBILITY)
+
+# libraries
+lib_LTLIBRARIES = libftimings-@FTIMINGS_API_VERSION@.la
+
+# libftimings
+libftimings_@FTIMINGS_API_VERSION@_la_SOURCES = \
+	ftimings/time.c \
+	ftimings/ftimings.f90
+libftimings_@FTIMINGS_API_VERSION@_la_LDFLAGS = -version-info $(FTIMINGS_SO_VERSION)
+
+ftimings_includedir = $(includedir)/ftimings-$(FTIMINGS_API_VERSION)
+nobase_ftimings_include_HEADERS = ftimings.mod
+ftimings_libincludedir = $(libdir)/ftimings-$(FTIMINGS_API_VERSION)/include
+
+pkgconfigdir = $(libdir)/pkgconfig
+pkgconfig_DATA = ftimings-$(FTIMINGS_API_VERSION).pc
+
+# programs
+bin_PROGRAMS = ftimings_test
+
+# test
+ftimings_test_SOURCES = test/test_timings.F90
+ftimings_test_LDADD = libftimings-@FTIMINGS_API_VERSION@.la

autogen.sh

+#!/bin/sh -e
+
+mkdir -p m4/
+
+test -n "$srcdir" || srcdir=`dirname "$0"`
+test -n "$srcdir" || srcdir=.
+
+autoreconf --force --install --verbose "$srcdir"

configure.ac

+AC_INIT([libftimings], [0.1])
+AC_PREREQ([2.59])
+AC_CONFIG_MACRO_DIR([m4])
+
+AC_CONFIG_HEADERS([config.h])
+
+AM_INIT_AUTOMAKE([foreign -Wall -Werror])
+m4_ifdef([AM_PROG_AR], [AM_PROG_AR])
+AM_PROG_CC_C_O
+
+AC_PROG_FC
+AC_FC_LIBRARY_LDFLAGS
+AC_FC_FREEFORM
+
+LT_INIT
+
+PKG_PROG_PKG_CONFIG
+
+AC_SUBST([FTIMINGS_SO_VERSION], [0:1:0])
+AC_SUBST([FTIMINGS_API_VERSION], [0.1])
+
+AC_CONFIG_FILES([Makefile
+		 ftimings-${FTIMINGS_API_VERSION}.pc:ftimings.pc.in
+		 ])
+AC_OUTPUT

ftimings.pc.in

+prefix=@prefix@
+exec_prefix=@exec_prefix@
+libdir=@libdir@
+includedir=@includedir@
+
+Name: @PACKAGE_NAME@
+Description: FTIMINGS
+Version: @PACKAGE_VERSION@
+URL: @PACKAGE_URL@
+Libs: -L${libdir} -lftimings-@FTIMINGS_API_VERSION@
+fcflags= -I${includedir}/ftimings-@FTIMINGS_API_VERSION@

ftimings/ftimings.f90

+module ftimings
+  use, intrinsic :: iso_c_binding, only : C_INT64_T, C_DOUBLE
+  implicit none
+  save
+
+  public
+
+  integer, parameter, private :: name_length = 32
+  integer, parameter, private :: rk = C_DOUBLE
+
+  interface
+    function microseconds_since_epoch() result(ms) bind(C, name="microseconds_since_epoch")
+      use, intrinsic :: iso_c_binding
+      implicit none
+      integer(kind=C_INT64_T) :: ms
+    end function
+  end interface
+
+  type node_t
+    character(len=name_length) :: name
+    integer(kind=C_INT64_T) :: micros
+    integer :: count
+    type(node_t), pointer :: firstChild
+    type(node_t), pointer :: lastChild
+    type(node_t), pointer :: parent
+    type(node_t), pointer :: nextSibling
+    contains
+      procedure, pass :: new_child => node_new_child
+      procedure, pass :: get_child => node_get_child
+      procedure, pass :: print_graph => node_print_graph
+      procedure, pass :: sum_of_children => node_sum_of_children
+      procedure, pass :: sum_of_children_with_name => node_sum_of_children_with_name
+  end type
+
+  type timer_t
+    logical :: active = .false.
+    type(node_t), pointer :: root
+    type(node_t), pointer :: current_node
+    contains
+      procedure, pass :: start => timer_start
+      procedure, pass :: stop => timer_stop
+      procedure, pass :: free => timer_free
+      procedure, pass :: print => timer_print
+      procedure, pass :: enable => timer_enable
+      procedure, pass :: disable => timer_disable
+      procedure, pass :: is_enabled => timer_is_enabled
+      procedure, pass :: in_entries => timer_in_entries
+      procedure, pass :: get => timer_get
+      procedure, pass :: since => timer_since
+  end type
+
+  type(timer_t) :: timer
+
+  character(len=name_length), parameter :: own = "(own)"
+
+  contains
+
+  function node_new_child(self, name) result(new)
+    class(node_t), intent(inout), target :: self
+    character(len=*), intent(in) :: name
+    type(node_t), pointer :: new
+
+    if (.not. associated(self%lastChild)) then
+      allocate(self%lastChild)
+      new => self%lastChild
+      self%firstChild => new
+    else
+      allocate(self%lastChild%nextSibling)
+      new => self%lastChild%nextSibling
+      self%lastChild => new
+    endif
+
+    new%name = name
+    new%micros = 0
+    new%count = 0
+
+    select type (self)
+      type is (node_t)
+        new%parent => self
+      class default
+        stop "node_new_child(): This should not happen"
+    end select
+
+    nullify(new%firstChild)
+    nullify(new%lastChild)
+    nullify(new%nextSibling)
+
+  end function
+
+  function string_eq(str1, str2) result(eq)
+    character(len=name_length), intent(in) :: str1
+    character(len=*), intent(in) :: str2
+    logical :: eq
+    eq = trim(str1) .eq. str2(1:min(len(trim(str2)), name_length))
+  end function
+
+  function node_get_child(self, name) result(child)
+    class(node_t), intent(in) :: self
+    character(len=*), intent(in) :: name
+    type(node_t), pointer :: child
+
+    child => self%firstChild
+    do while (associated(child))
+      if (string_eq(child%name, name)) then
+        return
+      endif
+      child => child%nextSibling
+    enddo
+    nullify(child)
+  end function
+
+  recursive subroutine deallocate_node(entry)
+    type(node_t), intent(inout), pointer :: entry
+    type(node_t), pointer :: nextSibling
+
+    if (associated(entry%firstChild)) then
+      call deallocate_node(entry%firstChild)
+    endif
+    nextSibling => entry%nextSibling
+    deallocate(entry)
+    nullify(entry)
+    if (associated(nextSibling)) then
+      call deallocate_node(nextSibling)
+    endif
+  end subroutine
+
+  function node_sum_of_children(self) result(sum_time)
+    class(node_t), intent(in) :: self
+    type(node_t), pointer :: cur_entry
+    integer(kind=C_INT64_T) :: sum_time, child_time
+
+    sum_time = 0
+    cur_entry => self%firstChild
+    do while (associated(cur_entry))
+      sum_time = sum_time + cur_entry%micros
+      if (cur_entry%micros < 0) then
+        ! child has not finished, give time up to NOW
+        sum_time = sum_time + microseconds_since_epoch()
+      endif
+      cur_entry => cur_entry%nextSibling
+    enddo
+  end function
+
+  recursive function node_sum_of_children_with_name(self, name) result(sum_time)
+    class(node_t), intent(in) :: self
+    character(len=*), intent(in) :: name
+    type(node_t), pointer :: cur_entry
+    integer(kind=C_INT64_T) :: sum_time
+
+    sum_time = 0
+    cur_entry => self%firstChild
+    do while (associated(cur_entry))
+      if (string_eq(cur_entry%name, name)) then
+        sum_time = sum_time + cur_entry%micros
+      else
+        sum_time = sum_time + cur_entry%sum_of_children_with_name(name)
+      endif
+      cur_entry => cur_entry%nextSibling
+    enddo
+  end function
+
+  recursive subroutine node_print_graph(self, indent_level)
+    class(node_t), intent(in) :: self
+    integer, intent(in) :: indent_level
+
+    character(len=64) :: format_spec
+    character(len=name_length) :: name, suffix
+    integer :: i
+    integer(kind=C_INT64_T) :: current_ms
+
+    if (self%micros < 0) then
+      ! still running, give time up to NOW
+      current_ms = self%micros + microseconds_since_epoch()
+      write(format_spec,'("(",i0,"x,""|_ "",a",i0,",2x,f10.6,"" (running)"")")') indent_level * 2 + 2, len(self%name)
+    else
+      current_ms = self%micros
+      write(format_spec,'("(",i0,"x,""|_ "",a",i0,",2x,f10.6)")') indent_level * 2 + 2, len(self%name)
+    endif
+
+    if (self%count > 1) then
+      write(suffix, '(" (",i0,"x)")') self%count
+      write(name, '(a,a)') self%name(1:min(name_length - len(trim(suffix)), len(trim(self%name)))), trim(suffix)
+    else
+      name = self%name
+    endif
+    do i = len(trim(name)) + 2, name_length
+      name(i:i) = "."
+    end do
+    write(*,format_spec) name, real(current_ms) / 1e6
+
+    if (associated(self%firstChild)) then
+      write(format_spec,'("(",i0,"x,""|_ "",a",i0,",2x,f10.6)")') (indent_level + 1) * 2 + 2, len(self%name)
+      write(*,format_spec) own, real(current_ms - self%sum_of_children()) / 1e6
+    endif
+
+    if (associated(self%firstChild)) then
+      call self%firstChild%print_graph(indent_level + 1)
+    endif
+    if (associated(self%nextSibling)) then
+      call self%nextSibling%print_graph(indent_level)
+    endif
+  end subroutine
+
+  subroutine timer_enable(self)
+    class(timer_t), intent(inout), target :: self
+    self%active = .true.
+  end subroutine
+
+  subroutine timer_disable(self)
+    class(timer_t), intent(inout), target :: self
+    self%active = .false.
+  end subroutine
+
+  function timer_is_enabled(self) result(is)
+    class(timer_t), intent(inout), target :: self
+    logical :: is
+    is = self%active
+  end function
+
+  ! Public module interface:
+
+  subroutine timer_start(self, name, replace)
+    class(timer_t), intent(inout), target :: self
+    character(len=*), intent(in)  :: name
+    logical, intent(in), optional  :: replace
+    type(node_t), pointer :: node
+    !$ integer :: omp_get_thread_num, omp_get_num_threads, omp_get_level, omp_get_ancestor_thread_num
+    !$ integer :: i
+
+    if (.not. self%active) then
+      return
+    endif
+
+    ! Deal with nested parallelization
+    !$ do i = 0, omp_get_level()
+    !$   if (omp_get_ancestor_thread_num(i) > 0) then
+    !$     return
+    !$   endif
+    !$ end do
+
+    !$omp master
+
+    if (.not. associated(self%current_node)) then
+      ! First call to timer_start()
+      allocate(self%current_node)
+      self%root => self%current_node
+      node => self%current_node
+      nullify(node%parent)
+      nullify(node%firstChild)
+      nullify(node%lastChild)
+      nullify(node%nextSibling)
+      node%name = name
+      node%micros = - microseconds_since_epoch()
+      node%count = 1
+    else
+      ! existing tree
+      if (string_eq(self%current_node%name, name)) then
+        !$omp critical
+        write(0,*) "Recursion error! Printing tree so far.."
+        write(0,*) "Got %start(""" // trim(name) // """), while %start(""" // trim(name) // """) was still active"
+        !$ write(*,*) "omp_get_thread_num() = ", omp_get_thread_num()
+        !$ write(*,*) "omp_get_num_threads() = ", omp_get_num_threads()
+        !$ write(*,*) "omp_get_level() = ", omp_get_level()
+        !$ do i = 0, omp_get_level()
+        !$   write(*,*) "omp_get_ancestor_thread_num(", i, ") = ", omp_get_ancestor_thread_num(i)
+        !$ end do
+        call self%root%print_graph(0)
+        !$omp end critical
+        stop "timer_start() while same timer was active"
+      endif
+      node => self%current_node%get_child(name)
+      if (.not. associated(node)) then
+        node => self%current_node%new_child(name)
+      else if (present(replace)) then
+        if (replace) then
+          node%micros = 0
+          node%count = 0
+          if (associated(node%firstChild)) then
+            call deallocate_node(node%firstChild)
+            nullify(node%firstChild)
+            nullify(node%lastChild)
+          endif
+        endif
+      endif
+      node%micros = node%micros - microseconds_since_epoch()
+      node%count = node%count + 1
+    endif
+
+    self%current_node => node
+
+    !$omp end master
+
+  end subroutine
+
+  subroutine timer_stop(self, name)
+    class(timer_t), intent(inout), target :: self
+    character(len=*), intent(in) :: name
+    logical :: error
+    !$ integer :: omp_get_level, omp_get_ancestor_thread_num
+    !$ integer :: i
+
+    if (.not. self%active) then
+      return
+    endif
+
+    ! Deal with nested parallelization
+    !$ do i = 0, omp_get_level()
+    !$   if (omp_get_ancestor_thread_num(i) > 0) then
+    !$     return
+    !$   endif
+    !$ end do
+
+    !$omp master
+    error = .false.
+
+    if (.not. associated(self%current_node)) then
+      write(0,'(a)') "Called %stop(""" // trim(name)  // """) without first calling %start(""" // trim(name) // &
+        & """), disabling timings"
+      call self%free()
+      self%active = .false.
+      error = .true.
+    else if (.not. string_eq(self%current_node%name, name)) then
+      write(0,'(a)') "Expected %stop(""" // trim(self%current_node%name)  // """), but got %stop(""" // trim(name) // &
+        & """, disabling timings)"
+      call self%free()
+      self%active = .false.
+      error = .true.
+    endif
+
+    if (.not. error) then
+      ! take the time
+      self%current_node%micros = self%current_node%micros + microseconds_since_epoch()
+
+      ! climb up to parent
+      if (associated(self%current_node%parent)) then
+        self%current_node => self%current_node%parent
+      else
+        nullify(self%current_node)
+      endif
+
+    endif
+    !$omp end master
+
+  end subroutine
+
+  subroutine timer_free(self)
+    class(timer_t), intent(inout), target :: self
+    if (associated(self%root)) then
+      call deallocate_node(self%root)
+    endif
+    nullify(self%root)
+    nullify(self%current_node)
+  end subroutine
+
+  subroutine timer_print(self, name1, name2, name3, name4)
+    class(timer_t), intent(in), target :: self
+    character(len=*), intent(in), optional :: name1, name2, name3, name4
+    type(node_t), pointer :: node
+
+    if (.not. self%active) then
+      return
+    endif
+
+    node => self%root
+    if (present(name1)) then
+      node => node%get_child(name1)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name1)  // """"
+        return
+      endif
+    end if
+    if (present(name2)) then
+      node => node%get_child(name2)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name2)  // """"
+        return
+      endif
+    end if
+    if (present(name3)) then
+      node => node%get_child(name3)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name3)  // """"
+        return
+      endif
+    end if
+    if (present(name4)) then
+      node => node%get_child(name4)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name4)  // """"
+        return
+      endif
+    end if
+    call node%print_graph(0)
+  end subroutine
+
+  !> Return the sum of all entries with a certain name below
+  !> a given node. Specify the name with the last argument, the
+  !> path to the starting point with the first few parameters
+  !>
+  !> \param name1, .., namei-1  The path to the starting node
+  !> \param namei               The name of all sub-entries below this
+  !>                            node to which are summed together
+  !>
+  !> For example timer%in_entries("foo", "bar", "parallel") returns
+  !> the sum of all entries named "parallel" below the foo->bar node
+  function timer_in_entries(self, name1, name2, name3, name4) result(s)
+    class(timer_t), intent(in), target :: self
+    character(len=*), intent(in) :: name1
+    character(len=*), intent(in), optional :: name2, name3, name4
+    real(kind=rk) :: s
+    type(node_t), pointer :: node ! the starting node
+    character(len=name_length) :: name ! the name of the sections
+
+    s = 0._rk
+
+    if (.not. self%active) then
+      return
+    endif
+
+    node => self%root
+    name = name1
+
+    if (present(name2)) then
+      node => node%get_child(name1)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name1)  // """"
+        return
+      endif
+      name = name2
+    end if
+    if (present(name3)) then
+      node => node%get_child(name2)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name2)  // """"
+        return
+      endif
+      name = name3
+    end if
+    if (present(name4)) then
+      node => node%get_child(name3)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name3)  // """"
+        return
+      endif
+      name = name4
+    end if
+
+    s = real(node%sum_of_children_with_name(name), kind=rk) / 1e6_rk
+  end function
+
+  function timer_get(self, name1, name2, name3, name4) result(s)
+    class(timer_t), intent(in), target :: self
+    character(len=*), intent(in), optional :: name1, name2, name3, name4
+    real(kind=rk) :: s
+    type(node_t), pointer :: node
+
+    s = 0._rk
+
+    if (.not. self%active) then
+      return
+    endif
+
+    node => self%root
+    if (present(name1)) then
+      node => node%get_child(name1)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name1)  // """"
+        return
+      endif
+    end if
+    if (present(name2)) then
+      node => node%get_child(name2)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name2)  // """"
+        return
+      endif
+    end if
+    if (present(name3)) then
+      node => node%get_child(name3)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name3)  // """"
+        return
+      endif
+    end if
+    if (present(name4)) then
+      node => node%get_child(name4)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name4)  // """"
+        return
+      endif
+    end if