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