mirror of https://github.com/saitohirga/WSJT-X.git
267 lines
7.4 KiB
Fortran
267 lines
7.4 KiB
Fortran
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
|