25 integer(kind=omp_nest_lock_kind):: lock
27 character(len=4):: kind =
'void' 31 real(8):: wait_time=0.0_8
32 real(8):: hold_time=0.0_8
33 real(8):: start_time=0.0_8
34 real(8):: used_time=0.0_8
35 integer(8):: n_hold=0_8
36 logical:: links=.false.
37 logical:: tasks=.false.
38 type(
lock_t),
pointer:: next => null()
47 procedure,
nopass:: info
49 integer,
save:: verbose=0
50 real,
save:: verbose_time=0.0
51 integer,
save:: id_save=-1, n_lock=0
52 logical,
save:: on = .true.
53 character(len=6):: log=
'queue' 54 character(len=6):: ext, ext1, ext2
56 real(8):: wait_time=0d0, alternate_time=0d0, alternate_next=0d0
57 type(
lock_t),
save,
public:: omp_lock
63 SUBROUTINE init (self, kind, id)
64 class(
lock_t),
target:: self
65 integer,
optional:: id
66 character(len=*),
optional:: kind
67 character(len=64):: filename
68 logical omp_in_parallel
69 logical,
save:: tasks=.true., links=.false.
72 logical:: first_time=.true.
73 namelist /lock_params/ on, verbose, verbose_time, log, tasks, links, &
78 call trace%begin(
'lock_t%init')
81 if (self%id == -1)
then 84 read (io_unit%input, lock_params, iostat=iostat)
85 write (io_unit%output, lock_params)
86 if (trim(log)==
'queue')
then 88 else if (trim(log)==
'log')
then 93 if (alternate_time > 0d0)
then 98 filename = trim(io_unit%rankbase)//ext
99 open (unit, file=trim(filename), form=
'formatted', &
101 alternate_next = wallclock() + alternate_time
105 call omp_init_nest_lock (self%lock)
106 omp_lock%tasks = tasks
107 omp_lock%links = links
108 if (
present(id))
then 110 id_save = max(id_save,id)
117 if (
present(kind)) self%kind = kind(1:4)
118 if (wallclock() < verbose_time .or. verbose > 1) &
119 write(unit,*) omp_get_thread_num(),
'initialized lock kind, id ', &
120 self%kind, self%id, set_id
124 if (omp%nthreads == 1) &
134 SUBROUTINE append (self)
135 class(
lock_t),
target:: self
139 self%next => omp_lock%next
140 omp_lock%next => self
143 END SUBROUTINE append
148 SUBROUTINE set (self, label)
150 character(len=*),
optional:: label
151 character(len=32):: filename
152 integer:: thread, othread, level
156 if (self%id == -1)
call self%init
158 call trace%begin(
'lock_t%set')
160 thread = omp_get_thread_num()
164 call alternate_log (self)
166 if (wc < verbose_time .or. verbose > 1 .or. alternate_time > 0d0)
then 167 if (
present(label))
then 168 write (unit,
'(f10.6,a,a4,i6,i3,i4,2x,a)') wc, &
169 ' lock kind, id, level, thread = ', self%kind, self%id, &
170 self%level, thread,
' get at '//label
172 write (unit,
'(f10.6,a,a4,i6,i3,i4,2x,a)') wc, &
173 ' lock kind, id, level, thread = ', self%kind, self%id, &
174 self%level, thread,
' get' 179 call omp_set_nest_lock (self%lock)
181 self%used_time = wc - self%start_time
182 self%wait_time = self%wait_time + self%used_time
183 self%n_hold = self%n_hold + 1
185 wait_time = wait_time + self%used_time
188 self%level = self%level+1
190 if (wc < verbose_time .or. verbose > 1 .or. alternate_time > 0d0)
then 191 write (unit,
'(f10.6,a,a4,i6,i3,i4,2x,a)') wc, &
192 ' lock kind, id, level, thread = ', self%kind, self%id, &
193 self%level, thread,
' set' 203 SUBROUTINE alternate_log (self)
207 if (alternate_time > 0d0)
then 209 if (wc > alternate_next)
then 214 open (unit, file=trim(io_unit%rankbase)//ext, form=
'formatted', &
216 alternate_next = wc + alternate_time
219 END SUBROUTINE alternate_log
224 FUNCTION test (self)
RESULT (out)
232 call trace%begin(
'lock_t%test')
234 thread = omp_get_thread_num()
238 if (thread == self%thread)
then 243 out = omp_test_nest_lock(self%lock)
247 self%level = self%level+1
249 if (wc < verbose_time .or. verbose > 1 .or. alternate_time > 0d0)
then 250 write (io_unit%log,
'(f10.6,i4,a,i6,i3,a)') wc, thread,
' lock id', &
251 self%id, self%level,
' test' 266 FUNCTION check (self)
RESULT (out)
271 thread = omp_get_thread_num()
272 out = (thread == self%thread)
278 SUBROUTINE unset (self, label)
280 character(len=*),
optional:: label
281 integer:: thread, level
286 call trace%begin(
'lock_t%unset')
288 thread = omp_get_thread_num()
290 self%level = self%level-1
292 if (self%level==0)
then 296 call omp_unset_nest_lock (self%lock)
298 self%used_time = wc - self%start_time
299 self%hold_time = self%hold_time + self%used_time
302 call alternate_log (self)
303 if (wc < verbose_time .or. verbose > 1 .or. alternate_time > 0d0)
then 304 if (
present(label))
then 305 write (unit,
'(f10.6,a,a4,i6,i3,i4,2x,a)') wc, &
306 ' lock kind, id, level, thread = ', self%kind, self%id, level, thread,
' unset at '//label
308 write (unit,
'(f10.6,a,a4,i6,i3,i4,2x,a)') wc, &
309 ' lock kind, id, level, thread = ', self%kind, self%id, level, thread,
' unset' 318 SUBROUTINE destroy (self)
322 call omp_destroy_nest_lock (self%lock)
324 END SUBROUTINE destroy
327 SUBROUTINE info (unit)
330 type(
lock_t),
pointer:: lock
333 if (verbose > 0)
then 334 lock => omp_lock%next
336 write (unit,
'(1x,a)')
' id type wait wait/n hold hold/n n' 337 do while (
associated(lock))
338 write (unit,
'(i6,2x,a4,4f12.6,i12)') lock%id, lock%kind, &
339 lock%wait_time, 1d3*lock%wait_time/max(lock%n_hold,1_8), &
340 lock%hold_time, 1d3*lock%hold_time/max(lock%n_hold,1_8), &
342 lock%wait_time = 0.0_8
343 lock%hold_time = 0.0_8
351 write (unit,
'(a,f10.3)')
' total lock waiting time =', time
Support tic/toc timing, as in MATLAB, and accurate wallclock() function. The timing is generally much...
The lock module uses nested locks, to allow versatile use of locks, where a procedure may want to mak...