DISPATCH
link_mod.f90
1 !*******************************************************************************
2 !> Module with list handling for generic class task_t objects.
3 !>
4 !> NOTE: The advantages of using the same links to organize a ready queue and
5 !> an active queue is that the process is faster and simpler when no new links
6 !> have to be created
7 !*******************************************************************************
8 MODULE link_mod
9  USE io_mod
10  USE io_unit_mod
11  USE omp_mod
12  USE mpi_mod
13  USE mpi_mesg_mod
14  USE trace_mod
15  USE bits_mod
16  USE task_mod
17  USE omp_timer_mod
18  USE omp_lock_mod
19  USE timer_mod
20  implicit none
21  private
22 
23  type, public:: link_t
24  class(task_t), pointer :: task => null() ! task
25  class(link_t), pointer :: nbor => null() ! next nbor; wouldn't `nbor_head` be a better name?
26  class(link_t), pointer :: link => null() ! pointer from nbor link to task list link (can be useful)
27  class(link_t), pointer :: next => null() ! next link in task list
28  class(link_t), pointer :: prev => null() ! previous link in task list
29  class(link_t), pointer :: parent => null() ! parent task link
30  class(link_t), pointer :: next_time => null() ! next link in time order
31  class(link_t), pointer :: next_active => null() ! next link to an active process, in time order
32  class(link_t), pointer :: nbors_by_level => null()! decreasing level sorted list
33  type(lock_t):: lock, qlock
34  logical:: initialized = .false.
35  logical:: check = .true.
36  !---------------------------------------------------------------------------
37  ! Flags making it possible to distinguish between nbors needed for link%task,
38  ! and nbors that need link%task. These flags are only used in nbor lists,
39  ! so when parsing the list starting with link%nbor, one uses nbor%needed
40  ! in check_ready(), and nbor%needs_me in check_nbors().
41  !---------------------------------------------------------------------------
42  logical:: needed = .true. ! marks nbors included in check_nbors()
43  logical:: needs_me = .true. ! marks nbors included in check_ready()
44  logical:: download = .true. ! marks nbors included in download_link()
45  contains
46  procedure:: init
47  procedure, nopass:: init_verbose
48  procedure:: add_nbor_by_quality
49  procedure:: add_nbor_by_rank
50  procedure:: add_nbor_link_by_rank
51  procedure:: remove_nbor
52  procedure:: remove_from_nbors
53  procedure:: remove_nbor_list
54  procedure:: remove_nbor_list2
55  procedure:: copy_nbor_list
56  procedure:: make_new_nbors
57  procedure:: make_new_nbor
58  !procedure:: update_nbors
59  procedure:: log_nbors
60  procedure:: print_nbors
61  procedure:: check_level_sort
62  procedure, nopass:: garbage_collect
63  procedure, nopass:: garbage_remove
64  procedure:: delete
65  procedure:: sort_nbors_by_level
66  procedure:: nbor_info
67  procedure:: info
68  end type
69  type(link_t), target, public:: garbage
70  integer:: garbage_n=0, verbose=0
71  logical, save:: debug=.false.
72 CONTAINS
73 
74 !===============================================================================
75 !> If link is not already initialized, initialize its lock. If an init is at
76 !> all made (not done for nbor links), it is done by the thread that allocated
77 !> the link, so there should be no need for a crtical region.
78 !===============================================================================
79 SUBROUTINE init (self)
80  class(link_t):: self
81  !.............................................................................
82  if (.not.self%initialized) then
83  self%initialized = .true.
84  call self%lock%init ('nbor')
85  call self%qlock%init ('queue')
86  if (associated(self%task)) then
87  self%lock%id = self%task%id
88  self%qlock%id = self%task%id
89  end if
90  end if
91 END SUBROUTINE init
92 
93 !===============================================================================
94 !> Set the verbosity level (called from task_mesg_mod -- duplicates the setting
95 !> of verbose in the task_mesg_params namelist.
96 !===============================================================================
97 SUBROUTINE init_verbose (verb)
98  integer:: verb
99  !.............................................................................
100  !$omp atomic write
101  verbose = verb
102 END SUBROUTINE init_verbose
103 
104 !===============================================================================
105 !> Initialize the nbors chain of a new task (self), by
106 !> 1) adding the parent
107 !> 2) searching the parent nbors, adding tasks that overlap
108 !> Each time it adds an nbor, it should also add itself to that nbor's nbor list
109 !===============================================================================
110 SUBROUTINE make_new_nbors (self, selfp, parent)
111  class(link_t):: self
112  class(link_t), pointer:: selfp, parent, nbor
113  class(task_t), pointer:: t1, t2
114  !> ...........................................................................
115  call trace_begin('list_t%make_new_nbors', 1)
116  t1 => self%task
117  call self%make_new_nbor (selfp, parent) ! make me a neighbor of my parent
118  call parent%lock%set ('make_new_nbors')
119  nbor => parent%nbor ! start on parent's nbors chain
120  do while (associated(nbor))
121  t2 => nbor%task
122  if (.not.associated(self%task,nbor%task) &
123  .and. t1%overlaps (t2)) & ! if my task overlaps with that task
124  call self%make_new_nbor (selfp, nbor%nbor)! make a neighbor (and make me one)
125  nbor => nbor%next ! continue on parents nbors chain
126  end do
127  call parent%lock%unset ('make_new_nbors')
128  call trace_end
129 END SUBROUTINE make_new_nbors
130 
131 !===============================================================================
132 !> Add a link to a new neighbor to my nbors chain, and add myself into that
133 !> neighbor's neighbor chain. An nbor chain link has three pointers: a pointer
134 !> to its task, a pointer to the next link in the chain, and a pointer back to
135 !> the task list link to the task. We need to make and add two now nbor chain
136 !> links; one for our own nbors chain, and one for that's nbors chain. Both
137 !> are added in quality order
138 !===============================================================================
139 SUBROUTINE make_new_nbor (self, selfp, that)
140  class(link_t):: self
141  class(link_t), pointer:: selfp, that
142  class(link_t), pointer:: link1, link2
143  !> ...........................................................................
144  call trace_begin('list_t%make_new_nbor', 1)
145  allocate (link1) ! for our own nbors chain
146  link1%task => that%task ! the link points to that task
147  link1%nbor => that ! pointer to the nbor link
148  link1%link => that ! pointer to the nbor link
149  link1%parent => that%parent ! direct link to task parent
150  call self%add_nbor_by_quality (link1) ! add to that chain in quality order
151  allocate (link2) ! for that's nbors chain
152  link2%task => self%task ! that's new link points to my task
153  link2%nbor => selfp ! pointer back to self
154  link2%link => selfp ! pointer back to self
155  link2%parent => selfp%parent ! direct link to self parent
156  call that%add_nbor_by_quality (link2) ! add to my nbors chain in quality order
157  call trace_end
158 END SUBROUTINE make_new_nbor
159 
160 !===============================================================================
161 !> Add a link node into the nbors list of self, in increasing quality order.
162 !> self must be a link whose 'nbors' points to a chain of nbors
163 !===============================================================================
164 SUBROUTINE add_nbor_by_quality (self, this)
165  class(link_t):: self
166  class(link_t), pointer:: this
167  class(link_t), pointer:: next, prev
168  !.............................................................................
169  call trace_begin ('list_t%add_nbor_by_quality')
170  call self%lock%set ('add_nbor_by_quality')
171  !$omp atomic update
172  this%task%n_needed = this%task%n_needed + 1 ! because linked task derefined
173  if (verbose > 1) &
174  write (io_unit%mpi,'(f12.6,i4,i6,2x,a,i4,2x,a)') wallclock(), omp%thread, &
175  this%task%id, 'needed by', this%task%n_needed, 'add_by_q'
176  flush (io_unit%mpi)
177  nullify (prev)
178  next => self%nbor
179  do while (associated(next))
180  if (.not.associated(next%task,this%task)) then
181  if (next%task%level >= this%task%level) then
182  !-------------------------------------------------------------------------
183  ! Found a task we should be ahead of, so insert here
184  !-------------------------------------------------------------------------
185  this%next => next
186  if (associated(prev)) then
187  prev%next => this
188  else
189  self%nbor => this
190  end if
191  self%task%n_nbors = self%task%n_nbors+1
192  call trace_end
193  goto 9
194  end if
195  end if
196  prev => next
197  next => next%next
198  end do
199  !-----------------------------------------------------------------------------
200  ! This task has the highest quality, so append it
201  !-----------------------------------------------------------------------------
202  if (associated(prev)) then
203  prev%next => this
204  nullify (this%next)
205  else
206  self%nbor => this
207  end if
208  self%task%n_nbors = self%task%n_nbors+1
209 9 continue
210  call self%lock%unset ('add_nbor_by_quality')
211  call trace_end
212 END SUBROUTINE add_nbor_by_quality
213 
214 !===============================================================================
215 !> Check the status of a link and all nbor links
216 !===============================================================================
217 SUBROUTINE check_level_sort (self)
218  class(link_t):: self
219  class(link_t), pointer:: nbor
220  integer:: level
221  !.............................................................................
222  nbor => self%nbor
223  level = -1
224  do while (associated(nbor))
225  if (nbor%task%level < level) then
226  print *, self%task%id, 'WARNING: nbors not sorted by level'
227  nbor => self%nbor
228  do while (associated(nbor))
229  print *, 'nbor, level =', nbor%task%id, nbor%task%level
230  nbor => nbor%next
231  end do
232  return
233  end if
234  level = nbor%task%level
235  nbor => nbor%next
236  end do
237 END SUBROUTINE check_level_sort
238 
239 !===============================================================================
240 !> Add a task link to an nbor list, setting also the nbor relations, based on
241 !> the ranks of the link%task and the self%task (which must be the "owner" of
242 !> the nbor_list)
243 !===============================================================================
244 SUBROUTINE add_nbor_link_by_rank (self, nbor_list, link)
245  class(link_t):: self
246  class(link_t), pointer:: nbor_list, link
247  class(link_t), pointer:: nbor
248  !-----------------------------------------------------------------------------
249  call trace%begin ('link_t%add_nbor_link_by_rank')
250  allocate (nbor)
251  nbor%link => link
252  nbor%task => link%task
253  call self%add_nbor_by_rank (nbor_list, nbor)
254  call self%task%nbor_relations (nbor%task, nbor%needed, nbor%needs_me, &
255  nbor%download)
256  call trace%end ()
257 END SUBROUTINE add_nbor_link_by_rank
258 
259 !===============================================================================
260 !> Add a link node into the nbors list of self, in increasing rank order.
261 !> self must be a link whose 'nbors' points to a chain of nbors
262 !===============================================================================
263 SUBROUTINE add_nbor_by_rank (self, nbors, this)
264  class(link_t):: self
265  class(link_t), pointer:: nbors, this
266  class(link_t), pointer:: next, prev
267  !.............................................................................
268  call trace_begin ('list_t%add_nbor_by_rank', 3)
269  !$omp atomic update
270  this%task%n_needed = this%task%n_needed + 1 ! because linked task derefined
271  if (verbose > 1) &
272  write (io_unit%mpi,'(f12.6,i4,i6,2x,a,i4,2x,a)') wallclock(), omp%thread, &
273  this%task%id, 'needed by', this%task%n_needed, 'add_by_rank'
274  flush (io_unit%mpi)
275  if (io%verbose>2) &
276  write (io_unit%log,*) ' adding task', this%task%id, &
277  this%task%is_set(bits%boundary), this%task%is_set(bits%virtual), &
278  ' to nbor list of', self%task%id
279  nullify (prev)
280  next => nbors
281  !-------------------------------------------------------------------------
282  ! Check that the task is not self
283  !-------------------------------------------------------------------------
284  if (this%task%id == self%task%id) then
285  goto 9
286  end if
287  !-------------------------------------------------------------------------
288  ! Check that the new task is not already in the list
289  !-------------------------------------------------------------------------
290  do while (associated(next))
291  if (next%task%id == this%task%id) then
292  goto 9
293  end if
294  next => next%next
295  end do
296  !-------------------------------------------------------------------------
297  ! If not, find the right place to add it
298  !-------------------------------------------------------------------------
299  next => nbors
300  do while (associated(next))
301  if (next%task%rank >= this%task%rank) then
302  !-------------------------------------------------------------------------
303  ! Found a task we should be ahead of, so insert here
304  !-------------------------------------------------------------------------
305  this%next => next
306  if (associated(prev)) then
307  prev%next => this
308  else
309  nbors => this
310  end if
311  self%task%n_nbors = self%task%n_nbors+1
312  goto 9
313  end if
314  prev => next
315  next => next%next
316  end do
317  !-----------------------------------------------------------------------------
318  ! This task has the highest rank, so append it
319  !-----------------------------------------------------------------------------
320  if (associated(prev)) then
321  prev%next => this
322  nullify (this%next)
323  else
324  nbors => this
325  end if
326  self%task%n_nbors = self%task%n_nbors+1
327 9 continue
328  call trace_end
329 END SUBROUTINE add_nbor_by_rank
330 
331 
332 !===============================================================================
333 !> Remove this from the nbor list
334 !===============================================================================
335 SUBROUTINE remove_nbor (self, this)
336  class(link_t):: self
337  class(link_t), pointer:: this
338  class(link_t), pointer:: nbor, prev, next
339  integer, save:: itimer=0
340  !.............................................................................
341  call trace%begin ('link_mod::remove_nbor', 1, itimer=itimer)
342  call self%lock%set ('remove_nbor')
343  if (io%verbose>1) &
344  write (io_unit%log,*) 'removing task', this%task%id,associated(this%link), &
345  ' from nbor list of', self%task%id
346  nullify (prev)
347  nbor => self%nbor
348  do while (associated(nbor))
349  next => nbor%next
350  if (associated(nbor%task,this%task)) then
351  if (associated(prev)) then
352  prev%next => nbor%next
353  else
354  self%nbor => nbor%next
355  end if
356  deallocate (nbor)
357  self%task%n_nbors = self%task%n_nbors-1
358  goto 9
359  end if
360  prev => nbor
361  nbor => next
362  end do
363  if (io%verbose>2) &
364  write (io_unit%log,*) 'WARNING: remove_nbor could not find task', this%task%id
365 9 continue
366  call self%lock%unset ('remove_nbor')
367  call trace%end (itimer)
368 END SUBROUTINE remove_nbor
369 
370 !===============================================================================
371 !> Remove this task from the nbor lists of the nbors of self
372 !===============================================================================
373 SUBROUTINE remove_from_nbors (self, this)
374  class(link_t):: self
375  class(link_t), pointer:: this
376  class(link_t), pointer:: nbor
377  !.............................................................................
378  call trace_begin ('link_mod::remove_from_nbors', 2)
379  call self%lock%set ('remove_from_nbors')
380  nbor => self%nbor
381  do while (associated(nbor))
382  call nbor%link%remove_nbor (this)
383  nbor => nbor%next
384  end do
385  call self%lock%unset ('remove_from_nbors')
386  call trace_end
387 END SUBROUTINE remove_from_nbors
388 
389 !===============================================================================
390 !> Remove, deallocate, and nullify an existing nbor list
391 !===============================================================================
392 SUBROUTINE remove_nbor_list (self, nbors)
393  class(link_t):: self
394  class(link_t), pointer:: nbors, nbor, next, link2, nbor2, next2, prev
395  integer, save:: itimer=0
396  !-----------------------------------------------------------------------------
397  if (timer%detailed) &
398  call trace%begin ('link_t%remove_nbor_list', itimer=itimer)
399  if (verbose > 1) &
400  write (io_unit%mpi,'(f12.6,i4,2x,a)') wallclock(), omp%thread, 'remove_nbor_list'
401  nbor => nbors
402  do while (associated(nbor))
403  next => nbor%next
404  !$omp atomic update
405  nbor%task%n_needed = nbor%task%n_needed - 1
406  if (verbose > 1) then
407  write (io_unit%mpi,'(f12.6,i4,i6,2x,a,i4,2x,a)') wallclock(), omp%thread, &
408  nbor%task%id, 'needed by', nbor%task%n_needed, 'remove_nb_list'
409  flush (io_unit%mpi)
410  end if
411  deallocate (nbor)
412  nbor => next
413  end do
414  nullify (nbors)
415  if (timer%detailed) &
416  call trace%end (itimer)
417 END SUBROUTINE remove_nbor_list
418 
419 !===============================================================================
420 !> Remove, deallocate, and nullify an existing nbor list
421 !===============================================================================
422 SUBROUTINE remove_nbor_list2 (self, nbors)
423  class(link_t):: self
424  class(link_t), pointer:: nbors, nbor, next, link2, nbor2, next2, prev
425  integer, save:: itimer=0
426  !-----------------------------------------------------------------------------
427  call trace%begin ('link_t%remove_nbor_list2', itimer=itimer)
428  if (verbose > 1) &
429  write (io_unit%mpi,'(f12.6,i4,2x,a)') wallclock(), omp%thread, 'remove_nbor_list'
430  nbor => nbors
431  do while (associated(nbor))
432  next => nbor%next
433  !$omp atomic update
434  nbor%task%n_needed = nbor%task%n_needed - 1
435  if (verbose > 1) then
436  write (io_unit%mpi,'(f12.6,i4,i6,2x,a,i4,2x,a)') wallclock(), omp%thread, &
437  nbor%task%id, 'needed by', nbor%task%n_needed, 'remove_nb_list'
438  flush (io_unit%mpi)
439  end if
440  !---------------------------------------------------------------------------
441  ! Also remove self from the nbor list of nbor
442  !---------------------------------------------------------------------------
443  nullify (prev)
444  nbor2 => nbor%link%nbor
445  do while (associated(nbor2))
446  if (nbor2%task%id == self%task%id) then
447  if (associated(prev)) then
448  prev%next => nbor2%next
449  else
450  nbor%link%nbor => nbor2%next
451  end if
452  end if
453  prev => nbor2
454  nbor2 => nbor2%next
455  end do
456  deallocate (nbor)
457  nbor => next
458  end do
459  nullify (nbors)
460  call trace%end (itimer)
461 END SUBROUTINE remove_nbor_list2
462 
463 !===============================================================================
464 !> Create a temporary nbor list
465 !===============================================================================
466 SUBROUTINE copy_nbor_list (self, old_head, new_head)
467  class(link_t):: self
468  class(link_t), pointer:: old_head, new_head
469  !.............................................................................
470  class(link_t), pointer:: nbor, head, tail, new
471  integer:: itimer=0
472  !-----------------------------------------------------------------------------
473  call trace%begin ('link_t%copy_nbors', itimer=itimer)
474  nullify (head, tail)
475  nbor => old_head
476  do while (associated(nbor))
477  allocate (new, source=nbor)
478  new%task => nbor%task
479  new%link => nbor%link
480  !$omp atomic update
481  nbor%task%n_needed = nbor%task%n_needed + 1
482  if (verbose > 1) &
483  write (io_unit%mpi,'(f12.6,i4,i6,2x,a,i4,2x,a)') wallclock(), omp%thread, &
484  nbor%task%id, 'needed by', nbor%task%n_needed, 'copy_nb_list'
485  flush (io_unit%mpi)
486  !---------------------------------------------------------------------------
487  ! If the new list is empty the new link becomes the first one, and if not,
488  ! it becomes the next one after the last one
489  !---------------------------------------------------------------------------
490  if (associated(tail)) then
491  tail%next => new
492  else
493  head => new
494  end if
495  tail => new
496  nbor => nbor%next
497  end do
498  new_head => head
499  !-----------------------------------------------------------------------------
500  call trace%end (itimer)
501 END SUBROUTINE copy_nbor_list
502 
503 !===============================================================================
504 !> Update the nbor list of self, adding self to the each nbor's nbor list
505 !===============================================================================
506 ! SUBROUTINE update_nbors (self)
507  ! class(link_t):: self
508  ! class(link_t), pointer:: nbor, new
509  ! !.............................................................................
510  ! call trace_begin('link_t%update_nbors')
511  ! nbor => self%nbor ! start checking nbors
512  ! do while (associated(nbor)) ! loop over nbor list
513  ! allocate (new) ! new link for nbor's nbor list
514  ! new%task => self%task ! its task is the link task
515  ! new%link => self%task%link ! add also the link pointer
516  ! call nbor%add_nbor_by_rank (self%nbor, new) ! add a new nbor link
517  ! nbor => nbor%next ! continue on nbor list
518  ! end do
519  ! call trace_end
520 ! END SUBROUTINE update_nbors
521 
522 !===============================================================================
523 !> Print a list of nbors to the rank-thread log file
524 !===============================================================================
525 SUBROUTINE log_nbors (self, label)
526  class(link_t):: self
527  character(len=*), optional:: label
528  class(link_t) , pointer:: link, nbor
529  !.............................................................................
530  if (io%verbose < 1) return
531  if (present(label)) then
532  if (trim(label) /= '') write (io_unit%log,'(a)') label
533  end if
534  write (io_unit%log,'(a,i5,2x,a,f14.8,2x,a,l3,2x,a,i3,2x,a,$)') &
535  'task', self%task%id, 'time', self%task%time, &
536  'ready', self%task%is_set(bits%ready), 'level', self%task%level, 'nbors:'
537  if (io%verbose>4) write (io_unit%log,*) ''
538  link => self%nbor
539  do while (associated(link))
540  if (io%verbose>4) then
541  write (io_unit%log,'(i7,f14.8,l3)') &
542  link%task%id, link%task%time, link%task%is_set(bits%ready)
543  else
544  write (io_unit%log,'(i4,l2,$)') link%task%id, link%task%is_set(bits%ready)
545  end if
546  link => link%next
547  end do
548  write (io_unit%log,*) ''
549 END SUBROUTINE log_nbors
550 
551 !===============================================================================
552 !> Print a list of nbors to io_unit%mpi
553 !===============================================================================
554 SUBROUTINE print_nbors (self, label)
555  class(link_t):: self
556  character(len=*), optional:: label
557  class(link_t) , pointer:: nbor
558  integer:: idmax
559  character(len=16):: fmt
560  !.............................................................................
561  if (present(label)) write (io_unit%output,'(a,$)') label
562  write (io_unit%output, '(i6,l1," nbors:",$)') &
563  self%task%id, self%task%is_set (bits%ready)
564  idmax = 0
565  nbor => self%nbor
566  do while (associated(nbor))
567  idmax = max(idmax, nbor%task%id)
568  nbor => nbor%next
569  end do
570  idmax = floor(log10(real(idmax)))+2
571  write (fmt, '("(i",i1,",2l1,$)")') idmax
572  nbor => self%nbor
573  do while (associated(nbor))
574  write (io_unit%output,fmt) nbor%task%id, nbor%download, &
575  nbor%task%is_ahead_of(self%task)
576  if (.not.associated(nbor%link)) &
577  print *, 'link_t%print_nbors: WARNING, nbor%link not associated for task', &
578  nbor%task%id
579  nbor => nbor%next
580  end do
581  write (io_unit%output,*) ''
582 END SUBROUTINE print_nbors
583 
584 !===============================================================================
585 !> Collect garbage, and check if there is garbage to remove. This needs to be
586 !> done under lock protection, since many threads may be utilizing the GC at the
587 !> same time.
588 !===============================================================================
589 SUBROUTINE garbage_collect (link)
590  class(link_t), pointer:: link, nbor
591  !.............................................................................
592  call trace%begin ('link_t%garbage_collect')
593  flush (io_unit%mpi)
594  !-----------------------------------------------------------------------------
595  ! Immediately decrement the n_needed of the task, corresponding to the pending
596  ! deletion, and also reduce the n_needed of nbors and nbors_by_level, and remove
597  ! those list. The task itself will be removed when the n_needed count drops
598  ! to zero.
599  !-----------------------------------------------------------------------------
600  !$omp atomic update
601  link%task%n_needed = link%task%n_needed-1
602  if (verbose > 1) &
603  write (io_unit%mpi,'(f12.6,i4,i6,2x,a,i4,2x,a)') wallclock(), omp%thread, &
604  link%task%id, 'needed by', link%task%n_needed, 'garbage_collect'
605  call link%remove_nbor_list (link%nbor)
606  call link%remove_nbor_list (link%nbors_by_level)
607  !-----------------------------------------------------------------------------
608  ! If no other task needs this task remove it immediately, else add to garbage
609  !-----------------------------------------------------------------------------
610  if (link%task%n_needed <= 0) then
611  if (verbose > 0) then
612  write (io_unit%log,'(f12.6,2x,a,i4,2l4)') &
613  wallclock(), 'garbage_collect deleted: id =', link%task%id, &
614  link%task%n_needed, link%task%is_set(bits%virtual)
615  end if
616  !---------------------------------------------------------------------------
617  ! At this point, the link task has been removed from the task list, and
618  ! will never be the target of a download again, and hence will not be
619  ! needing the tasks on its nbor list. Their n_needed counts should thus
620  ! be decremented, and the sorted nbors list can also be removed. The
621  ! actual removal of the task is delayed until no other task needs it.
622  !---------------------------------------------------------------------------
623  call garbage%lock%set ('garbage')
624  call garbage_remove ! check consequences for nbors
625  call garbage%lock%unset ('garbage')
626  call link%delete (link)
627  else
628  call garbage%lock%set ('garbage')
629  garbage_n = garbage_n+1
630  link%next => garbage%next
631  garbage%next => link
632  if (verbose > 1) then
633  write (io_unit%output,*) 'garbage_collect: task, n_needed, garbage_n =', &
634  link%task%id, link%task%n_needed, garbage_n
635  flush (io_unit%output)
636  end if
637  !---------------------------------------------------------------------------
638  !> The tasks in the nbor list of the task pending deletion are no longer
639  !> needed by this task, so their n_needed counters should be decremented
640  !---------------------------------------------------------------------------
641  call garbage_remove
642  call garbage%lock%unset ('garbage')
643  end if
644  call trace%end()
645 END SUBROUTINE garbage_collect
646 
647 !===============================================================================
648 !> Check if there are links that may be deleted. The GC list with one member
649 !> looks like so: garbage%next -> link, link%next -> null()
650 !===============================================================================
651 SUBROUTINE garbage_remove
652  class(link_t), pointer:: link, next, prev
653  !.............................................................................
654  call trace%begin ('link_t%garbage_remove')
655  link => garbage%next
656  prev => garbage ! in case we remove the 1st link
657  do while (associated(link))
658  next => link%next
659  if (link%task%n_needed <= 0) then
660  if (verbose > 0) then
661  write (io_unit%log,'(f12.6,2x,a,i6,i4,l4)') &
662  wallclock(), 'garbage_remove deleted: id =', link%task%id, &
663  link%task%n_needed, link%task%is_set(bits%virtual)
664  end if
665  garbage_n = garbage_n-1
666  call link%delete (link) ! deallocate & delete task + link
667  prev%next => next ! remove from GC list
668  else
669  prev => link ! advance prev if not removed
670  end if
671  link => next
672  end do
673  call trace%end()
674 END SUBROUTINE garbage_remove
675 
676 !===============================================================================
677 !> Delete a link, and the corresponding task. First make sure to lock the link
678 !> and unset any remaining nested locks. Then delete the task, deallocate the
679 !> task itself, the link nbor list. Finally release the lock and delete the
680 !> link.
681 !===============================================================================
682 SUBROUTINE delete (self, link)
683  class(link_t):: self
684  class(link_t), pointer:: link
685  !.............................................................................
686  class(link_t), pointer:: nbor, next
687  !-----------------------------------------------------------------------------
688  call trace%begin ('link_t%delete')
689  !-----------------------------------------------------------------------------
690  call link%lock%set ('link_t%delete')
691  call link%task%log ('delete')
692  do while (link%lock%level > 1)
693  write (io_unit%output,*) 'delete_link unlocking lock level', link%lock%level
694  call link%lock%unset
695  end do
696  !-----------------------------------------------------------------------------
697  ! Remove / deallocate the unsorted nbor list before deleting the task
698  !-----------------------------------------------------------------------------
699  call link%remove_nbor_list (link%nbor)
700  call link%task%dealloc()
701  if (verbose > 1) then
702  write (io_unit%output,'(f12.5,2x,a,2i6)') &
703  wallclock(), 'delete: task, garbage_n =', link%task%id, garbage_n
704  flush (io_unit%output)
705  end if
706  deallocate (link%task)
707  nullify (link%task)
708  !-----------------------------------------------------------------------------
709  call link%lock%unset ('link_t%delete')
710  deallocate (link)
711  nullify (link)
712  !-----------------------------------------------------------------------------
713  call trace%end()
714 END SUBROUTINE delete
715 
716 !===============================================================================
717 !> Create a temporary nbor list, sorted by decreasing level
718 !===============================================================================
719 SUBROUTINE sort_nbors_by_level (self, old_head, new_head)
720  class(link_t):: self
721  class(link_t), pointer:: old_head, new_head
722  !.............................................................................
723  class(link_t), pointer:: nbor, head, prev, find
724  integer:: n_nbors
725  integer, save:: itimer=0
726  !-----------------------------------------------------------------------------
727  if (timer%detailed) &
728  call trace%begin ('link_t%sort_nbors_by_level', itimer=itimer)
729  if (verbose > 3) call nbor_print (old_head)
730  nullify (head)
731  n_nbors = 0
732  nbor => old_head
733  do while (associated(nbor))
734  call insert
735  n_nbors = n_nbors+1
736  nbor => nbor%next
737  end do
738  new_head => head
739  !-----------------------------------------------------------------------------
740  if (verbose > 2) call nbor_print (head)
741  if (verbose > 0) call nbor_check (new_head)
742  if (timer%detailed) &
743  call trace%end (itimer)
744 contains
745  !-----------------------------------------------------------------------------
746  ! Find a place to prepend a clone of nbor into chain with decreasing level.
747  ! As we scan through the new, sorted list, prev points to the previous link
748  !-----------------------------------------------------------------------------
749  subroutine insert
750  nullify(prev)
751  find => head
752  do while (associated(find))
753  if (find%task%level <= nbor%task%level) then
754  call prepend
755  return
756  end if
757  prev => find
758  find => find%next
759  end do
760  !---------------------------------------------------------------------------
761  ! Reached the end if the new nbor list, so the nbor%task should be appended,
762  ! which is the same as prepending to the previous (and thus last) link
763  !---------------------------------------------------------------------------
764  call prepend
765  return
766  end subroutine insert
767  !-----------------------------------------------------------------------------
768  ! Clone nbor and insert after prev, or as head
769  !-----------------------------------------------------------------------------
770  subroutine prepend
771  class(link_t), pointer:: new
772  allocate (new, source=nbor)
773  new%task => nbor%task
774  new%link => nbor%link
775  !$omp atomic update
776  nbor%task%n_needed = nbor%task%n_needed + 1
777  if (verbose > 1) &
778  write (io_unit%mpi,'(f12.6,i4,i6,2x,a,i4,2x,a)') wallclock(), omp%thread, &
779  nbor%task%id, 'needed by', nbor%task%n_needed, 'sort_by_level'
780  flush (io_unit%mpi)
781  new%next => find
782  if (associated(prev)) then
783  prev%next => new
784  else
785  head => new
786  end if
787  end subroutine prepend
788  !-----------------------------------------------------------------------------
789  ! Print nbor list
790  !-----------------------------------------------------------------------------
791  subroutine nbor_print (head)
792  class(link_t), pointer:: head, nbor
793  !---------------------------------------------------------------------------
794  write(io_unit%output,*) 'target: ', self%task%id
795  write(io_unit%output,*) 'sorted nbors:'
796  nbor => head
797  do while (associated(nbor))
798  write (io_unit%output,*) nbor%task%id, nbor%task%level
799  nbor => nbor%next
800  end do
801  end subroutine nbor_print
802  !-----------------------------------------------------------------------------
803  ! Check new nbor list for size and consistency
804  !-----------------------------------------------------------------------------
805  subroutine nbor_check (head)
806  class(link_t), pointer:: head, nbor
807  integer:: n, level
808  !---------------------------------------------------------------------------
809  n = 0
810  level = 999
811  nbor => head
812  do while (associated(nbor))
813  if (nbor%task%level > level) then
814  verbose = 5
815  call nbor_print (head)
816  call io%abort ('ERROR: sorted nbor list not monotonic')
817  end if
818  level = nbor%task%level
819  n = n+1
820  nbor => nbor%next
821  end do
822  if (n /= n_nbors) then
823  write (io_unit%output,*) 'nbor_check: n, nbors =', n, n_nbors
824  call io%abort ('ERROR: wrong number of nbors in sorted nbor list')
825  end if
826  end subroutine nbor_check
827 END SUBROUTINE sort_nbors_by_level
828 
829 !===============================================================================
830 !> Info for one nbor
831 !===============================================================================
832 SUBROUTINE nbor_info (self, task)
833  class(link_t):: self
834  class(task_t):: task
835  !-----------------------------------------------------------------------------
836  write(io_unit%mpi,'(3x,a,i6,2i4,2x,3l1,2x,2l1,3x,3f9.3)') &
837  'pa_t%nbor_info: id, rank, level, needed, needs_me, download, BV, pos =', &
838  self%task%id, self%task%rank, self%task%level, self%needed, self%needs_me, &
839  self%download, self%task%is_set(bits%boundary), &
840  self%task%is_set(bits%virtual), self%task%distance(task)/ &
841  (0.5d0*(task%size+self%task%size))
842 END SUBROUTINE nbor_info
843 
844 !===============================================================================
845 !> Info for all nbors
846 !===============================================================================
847 SUBROUTINE info (self)
848  class(link_t):: self
849  class(link_t), pointer:: nbor
850  !-----------------------------------------------------------------------------
851  call self%task%task_info()
852  nbor => self%nbor
853  do while (associated(nbor))
854  call nbor%nbor_info (self%task)
855  nbor => nbor%next
856  end do
857 END SUBROUTINE info
858 
859 END MODULE link_mod
Each thread uses a private timer data type, with arrays for start time and total time for each regist...
Definition: timer_mod.f90:11
Support tic/toc timing, as in MATLAB, and accurate wallclock() function. The timing is generally much...
Definition: io_mod.f90:4
The lock module uses nested locks, to allow versatile use of locks, where a procedure may want to mak...
Template module for tasks.
Definition: task_mod.f90:4