KTH framework for Nek5000 toolboxes; testing version  0.0.1
mntrtmr.f
Go to the documentation of this file.
1 
6 !=======================================================================
15  subroutine mntr_tmr_reg(mid,pmid,modid,mname,mdscr,ifsum)
16  implicit none
17 
18  include 'SIZE'
19  include 'PARALLEL' ! ISIZE
20  include 'MNTRLOGD'
21  include 'MNTRTMRD'
22  include 'FRAMELP'
23 
24  ! argument list
25  integer mid, pmid, modid
26  character*(*) mname, mdscr
27  logical ifsum
28 
29  ! local variables
30  character*10 lname
31  character*132 ldscr
32  integer slen,slena
33 
34  integer il, ipos
35 !-----------------------------------------------------------------------
36  ! check name length
37  slena = len_trim(adjustl(mname))
38  ! remove trailing blanks
39  slen = len_trim(mname) - slena + 1
40  if (slena.gt.mntr_lstl_mnm) then
41  call mntr_log(mntr_id,lp_deb,
42  $ 'too long timer name; shortenning')
43  slena = min(slena,mntr_lstl_mnm)
44  endif
45  call blank(lname,mntr_lstl_mnm)
46  lname= mname(slen:slen+slena- 1)
47  call capit(lname,slena)
48 
49  ! check description length
50  slena = len_trim(adjustl(mdscr))
51  ! remove trailing blanks
52  slen = len_trim(mdscr) - slena + 1
53  if (slena.ge.mntr_lstl_mds) then
54  call mntr_log(mntr_id,lp_deb,
55  $ 'too long timer description; shortenning')
56  slena = min(slena,mntr_lstl_mnm)
57  endif
58  call blank(ldscr,mntr_lstl_mds)
59  ldscr= mdscr(slen:slen + slena - 1)
60 
61  ! find empty space
62  ipos = 0
63 
64  ! to ensure consistency I do it on master and broadcast result
65  if (nid.eq.mntr_pid0) then
66 
67  ! check if module is already registered
68  do il=1,mntr_tmr_mpos
69  if (mntr_tmr_id(mntr_tmr_mark,il).ge.0.and.
70  $ mntr_tmr_name(il).eq.lname) then
71  ipos = -il
72  exit
73  endif
74  enddo
75 
76  ! find empty spot
77  if (ipos.eq.0) then
78  do il=1,mntr_tmr_id_max
79  if (mntr_tmr_id(mntr_tmr_mark,il).eq.-1) then
80  ipos = il
81  exit
82  endif
83  enddo
84  endif
85  endif
86 
87  ! broadcast mid
88  call bcast(ipos,isize)
89 
90  ! error; no free space found
91  if (ipos.eq.0) then
92  mid = ipos
93  call mntr_abort(mntr_id,
94  $ 'timer ['//trim(lname)//'] cannot be registered')
95  ! module already registered
96  elseif (ipos.lt.0) then
97  mid = abs(ipos)
98  call mntr_abort(mntr_id,
99  $ 'timer ['//trim(lname)//'] is already registered')
100  ! new module
101  else
102  mid = ipos
103  ! check if parent timer is registered
104  if (pmid.gt.0) then
105  if (mntr_tmr_id(mntr_tmr_mark,pmid).ge.0) then
106  mntr_tmr_id(mntr_tmr_mark,ipos) = pmid
107  else
108  mntr_tmr_id(mntr_tmr_mark,ipos) = 0
109  call mntr_log(mntr_id,lp_inf,
110  $ "timer's ["//trim(lname)//"] parent not registered.")
111  endif
112  else
113  mntr_tmr_id(mntr_tmr_mark,ipos) = 0
114  endif
115 
116  ! check if registerring module is registered
117  if (modid.gt.0) then
118  if (mntr_mod_id(modid).ge.0) then
119  mntr_tmr_id(mntr_tmr_mod,ipos) = modid
120  else
121  mntr_tmr_id(mntr_tmr_mod,ipos) = 0
122  call mntr_log(mntr_id,lp_inf,
123  $ "timer's ["//trim(lname)//"] module not registered.")
124  endif
125  else
126  mntr_tmr_id(mntr_tmr_mod,ipos) = 0
127  endif
128 
129  mntr_tmr_name(ipos)=lname
130  mntr_tmr_dscr(ipos)=ldscr
131  mntr_tmr_sum(ipos)=ifsum
132  mntr_tmr_num = mntr_tmr_num + 1
133  if (mntr_tmr_mpos.lt.ipos) mntr_tmr_mpos = ipos
134  call mntr_log(mntr_id,lp_inf,
135  $ 'Registered timer ['//trim(lname)//']: '//trim(ldscr))
136  endif
137 
138  return
139  end subroutine
140 !=======================================================================
145  subroutine mntr_tmr_is_name_reg(mid,mname)
146  implicit none
147 
148  include 'SIZE'
149  include 'PARALLEL' ! ISIZE
150  include 'MNTRLOGD'
151  include 'MNTRTMRD'
152  include 'FRAMELP'
153 
154  ! argument list
155  integer mid
156  character*(*) mname
157 
158  ! local variables
159  character*10 lname
160  character*3 str
161  integer slen,slena
162 
163  integer il, ipos
164 !-----------------------------------------------------------------------
165  ! check name length
166  slena = len_trim(adjustl(mname))
167  ! remove trailing blanks
168  slen = len_trim(mname) - slena + 1
169  if (slena.gt.mntr_lstl_mnm) then
170  call mntr_log(mntr_id,lp_deb,
171  $ 'too long timer name; shortenning')
172  slena = min(slena,mntr_lstl_mnm)
173  endif
174  call blank(lname,mntr_lstl_mnm)
175  lname= mname(slen:slen+slena- 1)
176  call capit(lname,slena)
177 
178  ! find module
179  ipos = 0
180 
181  ! to ensure consistency I do it on master and broadcast result
182  if (nid.eq.mntr_pid0) then
183  ! check if module is already registered
184  do il=1,mntr_tmr_mpos
185  if (mntr_tmr_id(mntr_tmr_mark,il).ge.0.and.
186  $ mntr_tmr_name(il).eq.lname) then
187  ipos = il
188  exit
189  endif
190  enddo
191  endif
192 
193  ! broadcast ipos
194  call bcast(ipos,isize)
195 
196  if (ipos.eq.0) then
197  mid = -1
198  call mntr_log(mntr_id,lp_inf,
199  $ 'timer ['//trim(lname)//'] not registered')
200  else
201  mid = ipos
202  write(str,'(I3)') ipos
203  call mntr_log(mntr_id,lp_vrb,
204  $ 'timer ['//trim(lname)//'] registered with id='//str)
205  endif
206 
207  return
208  end subroutine
209 !=======================================================================
214  logical function mntr_tmr_is_id_reg(mid)
215  implicit none
216 
217  include 'SIZE'
218  include 'PARALLEL'
219  include 'MNTRLOGD'
220  include 'MNTRTMRD'
221  include 'FRAMELP'
222 
223  ! argument list
224  integer mid
225 !-----------------------------------------------------------------------
226  mntr_tmr_is_id_reg = mntr_tmr_id(mntr_tmr_mark,mid).ge.0
227 
228  return
229  end function
230 !=======================================================================
236  subroutine mntr_tmr_add(mid,icount,time)
237  implicit none
238 
239  include 'SIZE'
240  include 'MNTRLOGD'
241  include 'MNTRTMRD'
242  include 'FRAMELP'
243 
244  ! argument list
245  integer mid, icount
246  real time
247 
248  ! local variables
249  character*3 str
250 !-----------------------------------------------------------------------
251  if (mntr_tmr_id(mntr_tmr_mark,mid).ge.0) then
252  mntr_tmrv_timer(mntr_tmr_count,mid) =
253  $ mntr_tmrv_timer(mntr_tmr_count,mid) + icount
254 
255  mntr_tmrv_timer(mntr_tmr_time,mid) =
256  $ mntr_tmrv_timer(mntr_tmr_time,mid) + time
257  else
258  write(str,'(I3)') mid
259  call mntr_log(mntr_id,lp_inf,
260  $ 'timer id='//trim(str)//' in mntr_tmr_add not registered')
261  endif
262 
263  return
264  end subroutine
265 !=======================================================================
268  subroutine mntr_tmr_summary_print()
269  implicit none
270 
271  include 'SIZE'
272  include 'MNTRLOGD'
273  include 'MNTRTMRD'
274  include 'FRAMELP'
275 
276  ! local variables
277  integer il, jl, maxlev, stride
278  parameter(stride=2)
279  integer olist(2,mntr_tmr_id_max), ierr, itmp
280  real timmin(mntr_tmr_id_max),timmax(mntr_tmr_id_max)
281  character*35 ftm
282  character*3 str
283 
284  ! functions
285  integer iglmax
286  real glmax, glmin, dnekclock
287 !-----------------------------------------------------------------------
288  call mntr_log(mntr_id,lp_prd,
289  $ 'Summary of registered timers')
290 
291  ! finalise framework timing
292  mntr_frame_tmini = dnekclock() - mntr_frame_tmini
293  call mntr_tmr_add(mntr_frame_tmr_id,1,mntr_frame_tmini)
294 
295  ! get ordered list
296  call mntr_tmr_get_olist(olist, ierr)
297  ierr = iglmax(ierr,1)
298  if (ierr.gt.0) then
299  call mntr_error(mntr_id,"Inconsistent timer tree.")
300  return
301  endif
302 
303  ! sum contributions from children if they are marked with mntr_tmr_sum
304  ! find max level for this run
305  maxlev = 1
306  do il=1,mntr_tmr_num
307  maxlev = max(maxlev,olist(2,il))
308  enddo
309 
310  do il=maxlev,1,-1
311  do jl=1,mntr_tmr_num
312  if (olist(2,jl).eq.il.and.mntr_tmr_sum(olist(1,jl))) then
313  itmp = mntr_tmr_id(mntr_tmr_mark,olist(1,jl))
314  ! sum iteration count
315  mntr_tmrv_timer(mntr_tmr_count,itmp) =
316  $ mntr_tmrv_timer(mntr_tmr_count,itmp) +
317  $ mntr_tmrv_timer(mntr_tmr_count,olist(1,jl))
318  ! sum timer
319  mntr_tmrv_timer(mntr_tmr_time,itmp) =
320  $ mntr_tmrv_timer(mntr_tmr_time,itmp) +
321  $ mntr_tmrv_timer(mntr_tmr_time,olist(1,jl))
322  endif
323  enddo
324  enddo
325 
326 
327  ! get max, min timers
328  do il=1,mntr_tmr_mpos
329  if (mntr_tmr_id(mntr_tmr_mark,il).ge.0) then
330  timmin(il) = glmin(mntr_tmrv_timer(mntr_tmr_time,il),1)
331  timmax(il) = glmax(mntr_tmrv_timer(mntr_tmr_time,il),1)
332  endif
333  enddo
334 
335  if (nid.eq.mntr_pid0) then
336 
337  if(ierr.eq.0.and.mntr_lp_def.le.lp_prd) then
338 
339  ! modify max level
340  maxlev = maxlev + 1
341 
342  ! print description
343  if (mntr_iftdsc) then
344  write (*,*) ' '
345  do il=1,mntr_tmr_num
346  write(str,'(I3)') stride*(olist(2,il))
347  ftm = '("[",A,"]",'//trim(str)//'X,A,'
348  write(str,'(I3)') stride*(maxlev-olist(2,il))
349  ftm = trim(ftm)//trim(str)//'X,": ",A)'
350  jl = olist(1,il)
351  write(*,ftm)
352  $ mntr_mod_name(mntr_tmr_id(mntr_tmr_mod,jl)),
353  $ mntr_tmr_name(jl), trim(mntr_tmr_dscr(jl))
354  enddo
355  endif
356 
357  ! print values
358  write(*,*) ' '
359  write(str,'(I3)') mntr_lstl_mnm +stride*maxlev-1
360  ftm='(A11,1X,A'//trim(adjustl(str))//',1X,":",4A15)'
361  write(*,ftm) 'Module name','Timer name','Count','Min time',
362  $ 'Max time', 'Max/count'
363  do il=1,mntr_tmr_num
364  write(str,'(I3)') stride*(olist(2,il))
365  ftm = '("[",A,"]",'//trim(str)//'X,A,'
366  write(str,'(I3)') stride*(maxlev-olist(2,il))
367  ftm = trim(ftm)//trim(str)//'X,":",4E15.8)'
368  jl = olist(1,il)
369  write(*,ftm) mntr_mod_name(mntr_tmr_id(mntr_tmr_mod,jl)),
370  $ mntr_tmr_name(jl), mntr_tmrv_timer(mntr_tmr_count,jl),
371  $ timmin(jl),timmax(jl),
372  $ timmax(jl)/max(1.0,mntr_tmrv_timer(mntr_tmr_count,jl))
373  enddo
374  write(*,*) ' '
375  endif
376  endif
377 
378  return
379  end subroutine
380 !=======================================================================
385  subroutine mntr_tmr_get_olist(olist,ierr)
386  implicit none
387 
388  include 'SIZE'
389  include 'FRAMELP'
390  include 'MNTRLOGD'
391  include 'MNTRTMRD'
392 
393  ! argument list
394  integer olist(2,mntr_tmr_id_max), ierr
395 
396  ! local variables
397  integer ind(mntr_tmr_id_max), level, parent, ipos
398  integer slist(2,mntr_tmr_id_max), itmp1(2)
399  integer npos, key
400  integer il, jl
401  integer istart, in, itest
402 !-----------------------------------------------------------------------
403  ierr = 0
404 
405  ! sort timer index array
406  ! copy data removing possible empty slots
407  npos=0
408  do il=1,mntr_tmr_mpos
409  if (mntr_tmr_id(mntr_tmr_mark,il).ge.0) then
410  npos = npos + 1
411  slist(1,npos) = mntr_tmr_id(mntr_tmr_mark,il)
412  slist(2,npos) = il
413  endif
414  enddo
415  if(npos.ne.mntr_tmr_num) then
416  ierr = 1
417  call mntr_log(mntr_id,lp_inf,
418  $ 'Inconsistent timer number; return')
419  return
420  endif
421 
422  ! sort with respect to parent id
423  key = 1
424  call ituple_sort(slist,2,npos,key,1,ind,itmp1)
425 
426  ! sort within children of single parent with respect to child id
427  istart = 1
428  itest = slist(1,istart)
429  do il=1,npos
430  if(itest.ne.slist(1,il).or.il.eq.npos) then
431  if (il.eq.npos.and.itest.eq.slist(1,il)) then
432  jl = npos + 1
433  else
434  jl = il
435  endif
436  in = jl - istart
437  if (itest.eq.0.and.in.ne.1) then
438  call mntr_log(mntr_id,lp_inf,
439  $ 'Must be single root of the graph; return')
440  ierr = 2
441  return
442  endif
443  if (in.gt.1) then
444  key = 2
445  call ituple_sort(slist(1,istart),2,in,key,1,ind,itmp1)
446  endif
447  if (il.ne.npos) then
448  itest = slist(1,il)
449  istart = il
450  endif
451  endif
452  enddo
453 
454  parent = 0
455  level = 0
456  ipos = 1
457  call mntr_build_ord_list(olist,slist,npos,ipos,parent,level)
458 
459  return
460  end subroutine
461 !=======================================================================
462 
bcast
subroutine bcast(buf, len)
Definition: comm_mpi.f:431
mntr_tmr_is_name_reg
subroutine mntr_tmr_is_name_reg(mid, mname)
Check if timer name is registered and return its id.
Definition: mntrtmr.f:146
mntr_build_ord_list
recursive subroutine mntr_build_ord_list(olist, slist, nlist, npos, parent, level)
Build ordered list reflecting graph structure.
Definition: mntrlog.f:1014
mntr_tmr_add
subroutine mntr_tmr_add(mid, icount, time)
Check if timer id is registered. This operation is performed locally.
Definition: mntrtmr.f:237
mntr_tmr_summary_print
subroutine mntr_tmr_summary_print()
Print registered timers showing tree structure.
Definition: mntrtmr.f:269
mntr_abort
subroutine mntr_abort(mid, logs)
Abort simulation.
Definition: mntrlog.f:837
mntr_log
subroutine mntr_log(mid, priority, logs)
Write log message.
Definition: mntrlog.f:600
mntr_error
subroutine mntr_error(mid, logs)
Write error message.
Definition: mntrlog.f:820
mntr_tmr_get_olist
subroutine mntr_tmr_get_olist(olist, ierr)
Provide ordered list of registered timers for printing.
Definition: mntrtmr.f:386
mntr_tmr_is_id_reg
logical function mntr_tmr_is_id_reg(mid)
Check if timer id is registered. This operation is performed locally.
Definition: mntrtmr.f:215
mntr_tmr_reg
subroutine mntr_tmr_reg(mid, pmid, modid, mname, mdscr, ifsum)
Register new timer.
Definition: mntrtmr.f:16
capit
subroutine capit(lettrs, n)
Definition: ic.f:1648
blank
subroutine blank(A, N)
Definition: math.f:19
ituple_sort
subroutine ituple_sort(a, lda, n, key, nkey, ind, aa)
Definition: navier8.f:327