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