WSJT-X/lib/timer.f90

subroutine 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 /tracer_priv/ 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.

  !$ use omp_lib

  character*8 dname
  !$ integer tid
  integer onlevel(0:10)
  common/tracer/ limtrace,lu
  common/tracer_priv/level,onlevel

  parameter (MAXCALL=100)
  character*8 name(MAXCALL),space
  logical on(MAXCALL)
  real ut(MAXCALL),ut0(MAXCALL)
  !$ integer ntid(MAXCALL)
  integer nmax,ncall(MAXCALL),nlevel(MAXCALL),nparent(MAXCALL)
  common/data/nmax,name,on,ut,ut0,dut, &
       !$ ntid, &
       ncall,nlevel,nparent,total,sum,sumf,space

  data eps/0.000001/,ntrace/0/
  data level/0/,nmax/0/,space/'        '/
  data limtrace/0/,lu/-1/

  !$omp threadprivate(/tracer_priv/)

  !$omp critical(timer)
  if(limtrace.lt.0) go to 999
  if(lu.lt.1) lu=6
  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
  if(ntrace.lt.limtrace) write(lu,1020) ntrace,tname,k,level,nparent(n)
1020 format(i8,': ',a8,3i5)
  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 timer

recursive subroutine print_root(i)
  character*16 sname

  common/tracer/ limtrace,lu

  parameter (MAXCALL=100)
  character*8 name(MAXCALL),space
  logical on(MAXCALL)
  real ut(MAXCALL),ut0(MAXCALL)
  !$ integer ntid(MAXCALL)
  integer nmax,ncall(MAXCALL),nlevel(MAXCALL),nparent(MAXCALL)
  common/data/nmax,name,on,ut,ut0,dut, &
       !$ ntid, &
       ncall,nlevel,nparent,total,sum,sumf,space

  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