1module timer_impl
2  !$ use omp_lib
3  use :: iso_c_binding, only: c_ptr
4  use timer_module, only: timer_callback
5  implicit none
6
7  public :: init_timer, fini_timer
8  integer, public :: limtrace=0
9!  integer, public :: limtrace=10000000
10
11  private
12
13  integer, parameter :: MAXCALL=100
14  integer :: lu=6
15  real :: dut
16  integer :: i,nmax=0,ncall(MAXCALL),nlevel(MAXCALL),nparent(MAXCALL)
17  character(len=8) :: name(MAXCALL),space='        '
18  logical :: on(MAXCALL)
19  real :: total,sum,sumf,ut(MAXCALL),ut0(MAXCALL)
20  !$ integer :: j,l,m,ntid(MAXCALL)
21
22  !
23  ! C interoperable callback setup
24  !
25  public :: C_init_timer
26  abstract interface
27     subroutine C_timer_callback (context, dname, k)
28       use, intrinsic :: iso_c_binding, only: c_ptr
29       implicit none
30       type(c_ptr), intent(in) :: context
31       character(len=8), intent(in) :: dname
32       integer, intent(in) :: k
33     end subroutine C_timer_callback
34  end interface
35  type(c_ptr), private :: the_context
36  procedure(C_timer_callback), pointer, private :: the_C_callback
37
38contains
39  subroutine timer_callback_wrapper (dname, k)
40    implicit none
41    character(len=8), intent(in) :: dname
42    integer, intent(in) :: k
43    call the_C_callback (the_context, dname, k)
44  end subroutine timer_callback_wrapper
45
46  subroutine C_init_timer (context, callback) bind(C)
47    use, intrinsic :: iso_c_binding, only: c_ptr, c_funptr, c_f_procpointer
48    use iso_c_utilities, only: c_to_f_string
49    use timer_module, only: timer
50    implicit none
51    type(c_ptr), intent(in) :: context
52    type(c_funptr), intent(in) :: callback
53    the_context=context
54    call c_f_procpointer (callback, the_C_callback)
55    timer => timer_callback_wrapper
56  end subroutine C_init_timer
57
58  !
59  ! default Fortran implementation which is thread safe using OpenMP
60  !
61  subroutine default_timer (dname, k)
62
63    ! Times procedure number n between a call with k=0 (tstart) and with
64    ! k=1 (tstop). Accumulates sums of these times in array ut (user time).
65    ! Also traces all calls (for debugging purposes) if limtrace.gt.0
66    !
67    ! If this is used with OpenMP than the /timer_private/ common
68    ! block must be copyed into each thread of a thread team by using
69    ! the copyin() clause on the !$omp parallel directive that creates
70    ! the team.
71
72    implicit none
73
74    character(len=8), intent(in) :: dname
75    integer, intent(in) :: k
76
77    real :: ut1,eps=0.000001
78    integer :: n,ndiv,ntrace=0
79    !$ integer :: tid
80    character(len=8) :: tname
81    include 'timer_common.inc'
82
83    !$omp critical(timer)
84    if(limtrace.lt.0) go to 999
85    if(k.gt.1) go to 40                        !Check for "all done" (k>1)
86    onlevel(0)=0
87
88    !$ tid=omp_get_thread_num()
89    do n=1,nmax                                !Check for existing name/parent[/thread]
90       if(name(n).eq.dname &
91                                !$ .and.ntid(n).eq.tid &
92            ) then
93          if (on(n)) then
94             if (nparent(n).eq.onlevel(level-1)) goto 20
95          else
96             if (nparent(n).eq.onlevel(level)) goto 20
97          end if
98       end if
99    enddo
100
101    nmax=nmax+1                                !This is a new one
102    n=nmax
103    !$ ntid(n)=tid
104    ncall(n)=0
105    on(n)=.false.
106    ut(n)=eps
107    name(n)=dname
108
10920  if(k.eq.0) then                                !Get start times (k=0)
110       if(on(n)) then
111          print*,'Error in timer: ',dname,' already on.'
112       end if
113       level=level+1 !Increment the level
114       on(n)=.true.
115       !     call system_clock(icount,irate)
116       !     ut0(n)=float(icount)/irate
117       !     call cpu_time(ut0(n))
118       ut0(n)=secnds(0.0)
119
120       ncall(n)=ncall(n)+1
121       if(ncall(n).gt.1.and.nlevel(n).ne.level) then
122          !recursion is happening
123          !
124          !TODO: somehow need to account for this deeper call at the
125          !shallowest instance in the call chain and this needs to be
126          !done without incrementing anything here other than counters
127          !and timers
128          !
129          nlevel(n)=-1
130       else
131          nlevel(n)=level
132       endif
133       nparent(n)=onlevel(level-1)
134       onlevel(level)=n
135
136    else if(k.eq.1) then        !Get stop times and accumulate sums. (k=1)
137       if(on(n)) then
138          on(n)=.false.
139          !        call system_clock(icount,irate)
140          !        ut1=float(icount)/irate
141          !        call cpu_time(ut1)
142          ut1=secnds(0.0)
143
144          ut(n)=ut(n)+ut1-ut0(n)
145       endif
146       level=level-1
147    endif
148
149    ntrace=ntrace+1
150    tname='TopLevel'
151    if(nparent(n).ge.1 .and. nparent(n).le.MAXCALL) tname=name(nparent(n))
152    if(ntrace.lt.limtrace) write(lu,1020) ntrace,dname,k,level,nparent(n),tname
1531020 format(i8,': ',a8,3i5,2x,a8)
154    flush(lu)
155    go to 998
156
157    ! Write out the timer statistics
158
15940  write(lu,1040)
1601040 format(/' Name                 Time  Frac     dTime',       &
161         ' dFrac    Calls'/58('-'))
162
163    !$ !walk backwards through the database rolling up thread data by call chain
164    !$ do i=nmax,1,-1
165    !$    do j=1,i-1
166    !$       l=j
167    !$       m=i
168    !$       do while (name(l).eq.name(m))
169    !$          l=nparent(l)
170    !$          m=nparent(m)
171    !$          if (l.eq.0.or.m.eq.0) exit
172    !$       end do
173    !$       if (l.eq.0.and.m.eq.0) then
174    !$          !same call chain so roll up data
175    !$          ncall(j)=ncall(j)+ncall(i)
176    !$          ut(j)=ut(j)+ut(i)
177    !$          do n=1,nmax
178    !$            if (nparent(n).eq.i) nparent(n)=j
179    !$          end do
180    !$          name(i)=space
181    !$          exit
182    !$       end if
183    !$    end do
184    !$ end do
185
186    if(k.gt.100) then
187       ndiv=k-100
188       do i=1,nmax
189          ncall(i)=ncall(i)/ndiv
190          ut(i)=ut(i)/ndiv
191       enddo
192    endif
193
194    total=ut(1)
195    sum=0.
196    sumf=0.
197    call print_root(1)
198    write(lu,1070) sum,sumf
1991070 format(58('-')/32x,f10.3,f6.2)
200    nmax=0
201    eps=0.000001
202    ntrace=0
203    level=0
204    onlevel(0)=0
205
206998 flush(lu)
207
208999 continue
209
210    !$omp end critical(timer)
211    return
212  end subroutine default_timer
213
214  recursive subroutine print_root(i)
215    implicit none
216    integer, intent(in) :: i
217    character(len=16) :: sname
218    real :: dutf, utf
219    integer :: j, kk
220
221    if (i.le.nmax) then
222       if (name(i).ne.space) then
223          dut=ut(i)
224          do j=i,nmax
225             if (name(j).ne.space.and.nparent(j).eq.i) dut=dut-ut(j)
226          enddo
227          if(dut.lt.0.0) dut=0.0
228          utf=ut(i)/total
229          dutf=dut/total
230          sum=sum+dut
231          sumf=sumf+dutf
232          kk=nlevel(i)
233          sname=space(1:kk)//name(i)//space(1:8-kk)
234          write(lu,2000) sname,ut(i),utf,dut,dutf,ncall(i)
2352000      format(a16,2(f10.3,f6.2),i9)
236          do j=i,nmax
237             if(nparent(j).eq.i) call print_root(j)
238          enddo
239       end if
240    end if
241    return
242  end subroutine print_root
243
244  subroutine init_timer (filename)
245    use, intrinsic :: iso_c_binding, only: c_char
246    use timer_module, only: timer
247    implicit none
248    character(len=*), optional, intent(in) :: filename
249    include 'timer_common.inc'
250    data level/0/, onlevel/11 * 0/
251    if (present (filename)) then
252       open (newunit=lu, file=filename, status='unknown')
253    else
254       open (newunit=lu, file='timer.out', status='unknown')
255    end if
256    timer => default_timer
257  end subroutine init_timer
258
259  subroutine fini_timer ()
260    use timer_module, only: timer, null_timer
261    implicit none
262    timer => null_timer
263    close (lu)
264  end subroutine fini_timer
265
266end module timer_impl
267