WSJT-X/lib/timer_impl.f90

module timer_impl
  !$ use omp_lib
  use :: iso_c_binding, only: c_ptr
  use timer_module, only: timer_callback
  implicit none

  public :: init_timer, fini_timer
  integer, public :: limtrace=0
!  integer, public :: limtrace=10000000

  private

  integer, parameter :: MAXCALL=100
  integer :: lu=6
  real :: dut
  integer :: i,nmax=0,ncall(MAXCALL),nlevel(MAXCALL),nparent(MAXCALL)
  character(len=8) :: name(MAXCALL),space='        '
  logical :: on(MAXCALL)
  real :: total,sum,sumf,ut(MAXCALL),ut0(MAXCALL)
  !$ integer :: j,l,m,ntid(MAXCALL)

  !
  ! C interoperable callback setup
  !
  public :: C_init_timer
  abstract interface
     subroutine C_timer_callback (context, dname, k)
       use, intrinsic :: iso_c_binding, only: c_ptr
       implicit none
       type(c_ptr), intent(in) :: context
       character(len=8), intent(in) :: dname
       integer, intent(in) :: k
     end subroutine C_timer_callback
  end interface
  type(c_ptr), private :: the_context
  procedure(C_timer_callback), pointer, private :: the_C_callback

contains
  subroutine timer_callback_wrapper (dname, k)
    implicit none
    character(len=8), intent(in) :: dname
    integer, intent(in) :: k
    call the_C_callback (the_context, dname, k)
  end subroutine timer_callback_wrapper

  subroutine C_init_timer (context, callback) bind(C)
    use, intrinsic :: iso_c_binding, only: c_ptr, c_funptr, c_f_procpointer
    use iso_c_utilities, only: c_to_f_string
    use timer_module, only: timer
    implicit none
    type(c_ptr), intent(in) :: context
    type(c_funptr), intent(in) :: callback
    the_context=context
    call c_f_procpointer (callback, the_C_callback)
    timer => timer_callback_wrapper
  end subroutine C_init_timer

  !
  ! default Fortran implementation which is thread safe using OpenMP
  !
  subroutine default_timer (dname, k)

    ! Times procedure number n between a call with k=0 (tstart) and with
    ! k=1 (tstop). Accumulates sums of these times in array ut (user time).
    ! Also traces all calls (for debugging purposes) if limtrace.gt.0
    !
    ! If this is used with OpenMP than the /timer_private/ common
    ! block must be copyed into each thread of a thread team by using
    ! the copyin() clause on the !$omp parallel directive that creates
    ! the team.

    implicit none

    character(len=8), intent(in) :: dname
    integer, intent(in) :: k

    real :: ut1,eps=0.000001
    integer :: n,ndiv,ntrace=0
    !$ integer :: tid
    character(len=8) :: tname
    include 'timer_common.inc'

    !$omp critical(timer)
    if(limtrace.lt.0) go to 999
    if(k.gt.1) go to 40                        !Check for "all done" (k>1)
    onlevel(0)=0

    !$ tid=omp_get_thread_num()
    do n=1,nmax                                !Check for existing name/parent[/thread]
       if(name(n).eq.dname &
                                !$ .and.ntid(n).eq.tid &
            ) then
          if (on(n)) then
             if (nparent(n).eq.onlevel(level-1)) goto 20
          else
             if (nparent(n).eq.onlevel(level)) goto 20
          end if
       end if
    enddo

    nmax=nmax+1                                !This is a new one
    n=nmax
    !$ ntid(n)=tid
    ncall(n)=0
    on(n)=.false.
    ut(n)=eps
    name(n)=dname

20  if(k.eq.0) then                                !Get start times (k=0)
       if(on(n)) then
          print*,'Error in timer: ',dname,' already on.'
       end if
       level=level+1 !Increment the level
       on(n)=.true.
       !     call system_clock(icount,irate)
       !     ut0(n)=float(icount)/irate
       !     call cpu_time(ut0(n))
       ut0(n)=secnds(0.0)

       ncall(n)=ncall(n)+1
       if(ncall(n).gt.1.and.nlevel(n).ne.level) then
          !recursion is happening
          !
          !TODO: somehow need to account for this deeper call at the
          !shallowest instance in the call chain and this needs to be
          !done without incrementing anything here other than counters
          !and timers
          !
          nlevel(n)=-1
       else
          nlevel(n)=level
       endif
       nparent(n)=onlevel(level-1)
       onlevel(level)=n

    else if(k.eq.1) then        !Get stop times and accumulate sums. (k=1)
       if(on(n)) then
          on(n)=.false.
          !        call system_clock(icount,irate)
          !        ut1=float(icount)/irate
          !        call cpu_time(ut1)
          ut1=secnds(0.0)

          ut(n)=ut(n)+ut1-ut0(n)
       endif
       level=level-1
    endif

    ntrace=ntrace+1
    tname='TopLevel'
    if(nparent(n).ge.1 .and. nparent(n).le.MAXCALL) tname=name(nparent(n))
    if(ntrace.lt.limtrace) write(lu,1020) ntrace,dname,k,level,nparent(n),tname
1020 format(i8,': ',a8,3i5,2x,a8)
    flush(lu)
    go to 998

    ! Write out the timer statistics

40  write(lu,1040)
1040 format(/' Name                 Time  Frac     dTime',       &
         ' dFrac    Calls'/58('-'))

    !$ !walk backwards through the database rolling up thread data by call chain
    !$ do i=nmax,1,-1
    !$    do j=1,i-1
    !$       l=j
    !$       m=i
    !$       do while (name(l).eq.name(m))
    !$          l=nparent(l)
    !$          m=nparent(m)
    !$          if (l.eq.0.or.m.eq.0) exit
    !$       end do
    !$       if (l.eq.0.and.m.eq.0) then
    !$          !same call chain so roll up data
    !$          ncall(j)=ncall(j)+ncall(i)
    !$          ut(j)=ut(j)+ut(i)
    !$          do n=1,nmax
    !$            if (nparent(n).eq.i) nparent(n)=j
    !$          end do
    !$          name(i)=space
    !$          exit
    !$       end if
    !$    end do
    !$ end do

    if(k.gt.100) then
       ndiv=k-100
       do i=1,nmax
          ncall(i)=ncall(i)/ndiv
          ut(i)=ut(i)/ndiv
       enddo
    endif

    total=ut(1)
    sum=0.
    sumf=0.
    call print_root(1)
    write(lu,1070) sum,sumf
1070 format(58('-')/32x,f10.3,f6.2)
    nmax=0
    eps=0.000001
    ntrace=0
    level=0
    onlevel(0)=0

998 flush(lu)

999 continue

    !$omp end critical(timer)
    return
  end subroutine default_timer

  recursive subroutine print_root(i)
    implicit none
    integer, intent(in) :: i
    character(len=16) :: sname
    real :: dutf, utf
    integer :: j, kk

    if (i.le.nmax) then
       if (name(i).ne.space) then
          dut=ut(i)
          do j=i,nmax
             if (name(j).ne.space.and.nparent(j).eq.i) dut=dut-ut(j)
          enddo
          if(dut.lt.0.0) dut=0.0
          utf=ut(i)/total
          dutf=dut/total
          sum=sum+dut
          sumf=sumf+dutf
          kk=nlevel(i)
          sname=space(1:kk)//name(i)//space(1:8-kk)
          write(lu,2000) sname,ut(i),utf,dut,dutf,ncall(i)
2000      format(a16,2(f10.3,f6.2),i9)
          do j=i,nmax
             if(nparent(j).eq.i) call print_root(j)
          enddo
       end if
    end if
    return
  end subroutine print_root

  subroutine init_timer (filename)
    use, intrinsic :: iso_c_binding, only: c_char
    use timer_module, only: timer
    implicit none
    character(len=*), optional, intent(in) :: filename
    include 'timer_common.inc'
    data level/0/, onlevel/11 * 0/
    if (present (filename)) then
       open (newunit=lu, file=filename, status='unknown')
    else
       open (newunit=lu, file='timer.out', status='unknown')
    end if
    timer => default_timer
  end subroutine init_timer

  subroutine fini_timer ()
    use timer_module, only: timer, null_timer
    implicit none
    timer => null_timer
    close (lu)
  end subroutine fini_timer

end module timer_impl