1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
|
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
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
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 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
|
