24 class(
task_t),
pointer :: task => null()
25 class(
link_t),
pointer :: nbor => null()
26 class(
link_t),
pointer :: link => null()
27 class(
link_t),
pointer :: next => null()
28 class(
link_t),
pointer :: prev => null()
29 class(
link_t),
pointer :: parent => null()
30 class(
link_t),
pointer :: next_time => null()
31 class(
link_t),
pointer :: next_active => null()
32 class(
link_t),
pointer :: nbors_by_level => null()
34 logical:: initialized = .false.
35 logical:: check = .true.
42 logical:: needed = .true.
43 logical:: needs_me = .true.
44 logical:: download = .true.
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
60 procedure:: print_nbors
61 procedure:: check_level_sort
62 procedure,
nopass:: garbage_collect
63 procedure,
nopass:: garbage_remove
65 procedure:: sort_nbors_by_level
69 type(
link_t),
target,
public:: garbage
70 integer:: garbage_n=0, verbose=0
71 logical,
save:: debug=.false.
79 SUBROUTINE init (self)
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
97 SUBROUTINE init_verbose (verb)
102 END SUBROUTINE init_verbose
110 SUBROUTINE make_new_nbors (self, selfp, parent)
112 class(
link_t),
pointer:: selfp, parent, nbor
113 class(
task_t),
pointer:: t1, t2
115 call trace_begin(
'list_t%make_new_nbors', 1)
117 call self%make_new_nbor (selfp, parent)
118 call parent%lock%set (
'make_new_nbors')
120 do while (
associated(nbor))
122 if (.not.
associated(self%task,nbor%task) &
123 .and. t1%overlaps (t2)) &
124 call self%make_new_nbor (selfp, nbor%nbor)
127 call parent%lock%unset (
'make_new_nbors')
129 END SUBROUTINE make_new_nbors
139 SUBROUTINE make_new_nbor (self, selfp, that)
141 class(
link_t),
pointer:: selfp, that
142 class(
link_t),
pointer:: link1, link2
144 call trace_begin(
'list_t%make_new_nbor', 1)
146 link1%task => that%task
149 link1%parent => that%parent
150 call self%add_nbor_by_quality (link1)
152 link2%task => self%task
155 link2%parent => selfp%parent
156 call that%add_nbor_by_quality (link2)
158 END SUBROUTINE make_new_nbor
164 SUBROUTINE add_nbor_by_quality (self, this)
166 class(
link_t),
pointer:: this
167 class(
link_t),
pointer:: next, prev
169 call trace_begin (
'list_t%add_nbor_by_quality')
170 call self%lock%set (
'add_nbor_by_quality')
172 this%task%n_needed = this%task%n_needed + 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' 179 do while (
associated(next))
180 if (.not.
associated(next%task,this%task))
then 181 if (next%task%level >= this%task%level)
then 186 if (
associated(prev))
then 191 self%task%n_nbors = self%task%n_nbors+1
202 if (
associated(prev))
then 208 self%task%n_nbors = self%task%n_nbors+1
210 call self%lock%unset (
'add_nbor_by_quality')
212 END SUBROUTINE add_nbor_by_quality
217 SUBROUTINE check_level_sort (self)
219 class(
link_t),
pointer:: nbor
224 do while (
associated(nbor))
225 if (nbor%task%level < level)
then 226 print *, self%task%id,
'WARNING: nbors not sorted by level' 228 do while (
associated(nbor))
229 print *,
'nbor, level =', nbor%task%id, nbor%task%level
234 level = nbor%task%level
237 END SUBROUTINE check_level_sort
244 SUBROUTINE add_nbor_link_by_rank (self, nbor_list, link)
246 class(
link_t),
pointer:: nbor_list, link
247 class(
link_t),
pointer:: nbor
249 call trace%begin (
'link_t%add_nbor_link_by_rank')
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, &
257 END SUBROUTINE add_nbor_link_by_rank
263 SUBROUTINE add_nbor_by_rank (self, nbors, this)
265 class(
link_t),
pointer:: nbors, this
266 class(
link_t),
pointer:: next, prev
268 call trace_begin (
'list_t%add_nbor_by_rank', 3)
270 this%task%n_needed = this%task%n_needed + 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' 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
284 if (this%task%id == self%task%id)
then 290 do while (
associated(next))
291 if (next%task%id == this%task%id)
then 300 do while (
associated(next))
301 if (next%task%rank >= this%task%rank)
then 306 if (
associated(prev))
then 311 self%task%n_nbors = self%task%n_nbors+1
320 if (
associated(prev))
then 326 self%task%n_nbors = self%task%n_nbors+1
329 END SUBROUTINE add_nbor_by_rank
335 SUBROUTINE remove_nbor (self, this)
337 class(
link_t),
pointer:: this
338 class(
link_t),
pointer:: nbor, prev, next
339 integer,
save:: itimer=0
341 call trace%begin (
'link_mod::remove_nbor', 1, itimer=itimer)
342 call self%lock%set (
'remove_nbor')
344 write (io_unit%log,*)
'removing task', this%task%id,
associated(this%link), &
345 ' from nbor list of', self%task%id
348 do while (
associated(nbor))
350 if (
associated(nbor%task,this%task))
then 351 if (
associated(prev))
then 352 prev%next => nbor%next
354 self%nbor => nbor%next
357 self%task%n_nbors = self%task%n_nbors-1
364 write (io_unit%log,*)
'WARNING: remove_nbor could not find task', this%task%id
366 call self%lock%unset (
'remove_nbor')
367 call trace%end (itimer)
368 END SUBROUTINE remove_nbor
373 SUBROUTINE remove_from_nbors (self, this)
375 class(
link_t),
pointer:: this
376 class(
link_t),
pointer:: nbor
378 call trace_begin (
'link_mod::remove_from_nbors', 2)
379 call self%lock%set (
'remove_from_nbors')
381 do while (
associated(nbor))
382 call nbor%link%remove_nbor (this)
385 call self%lock%unset (
'remove_from_nbors')
387 END SUBROUTINE remove_from_nbors
392 SUBROUTINE remove_nbor_list (self, nbors)
394 class(
link_t),
pointer:: nbors, nbor, next, link2, nbor2, next2, prev
395 integer,
save:: itimer=0
397 if (timer%detailed) &
398 call trace%begin (
'link_t%remove_nbor_list', itimer=itimer)
400 write (io_unit%mpi,
'(f12.6,i4,2x,a)') wallclock(), omp%thread,
'remove_nbor_list' 402 do while (
associated(nbor))
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' 415 if (timer%detailed) &
416 call trace%end (itimer)
417 END SUBROUTINE remove_nbor_list
422 SUBROUTINE remove_nbor_list2 (self, nbors)
424 class(
link_t),
pointer:: nbors, nbor, next, link2, nbor2, next2, prev
425 integer,
save:: itimer=0
427 call trace%begin (
'link_t%remove_nbor_list2', itimer=itimer)
429 write (io_unit%mpi,
'(f12.6,i4,2x,a)') wallclock(), omp%thread,
'remove_nbor_list' 431 do while (
associated(nbor))
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' 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
450 nbor%link%nbor => nbor2%next
460 call trace%end (itimer)
461 END SUBROUTINE remove_nbor_list2
466 SUBROUTINE copy_nbor_list (self, old_head, new_head)
468 class(
link_t),
pointer:: old_head, new_head
470 class(
link_t),
pointer:: nbor, head, tail, new
473 call trace%begin (
'link_t%copy_nbors', itimer=itimer)
476 do while (
associated(nbor))
477 allocate (new, source=nbor)
478 new%task => nbor%task
479 new%link => nbor%link
481 nbor%task%n_needed = nbor%task%n_needed + 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' 490 if (
associated(tail))
then 500 call trace%end (itimer)
501 END SUBROUTINE copy_nbor_list
525 SUBROUTINE log_nbors (self, label)
527 character(len=*),
optional:: label
528 class(
link_t) ,
pointer:: link, nbor
530 if (io%verbose < 1)
return 531 if (
present(label))
then 532 if (trim(label) /=
'')
write (io_unit%log,
'(a)') label
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,*)
'' 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)
544 write (io_unit%log,
'(i4,l2,$)') link%task%id, link%task%is_set(bits%ready)
548 write (io_unit%log,*)
'' 549 END SUBROUTINE log_nbors
554 SUBROUTINE print_nbors (self, label)
556 character(len=*),
optional:: label
557 class(
link_t) ,
pointer:: nbor
559 character(len=16):: fmt
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)
566 do while (
associated(nbor))
567 idmax = max(idmax, nbor%task%id)
570 idmax = floor(log10(
real(idmax)))+2
571 write (fmt,
'("(i",i1,",2l1,$)")') idmax
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', &
581 write (io_unit%output,*)
'' 582 END SUBROUTINE print_nbors
589 SUBROUTINE garbage_collect (link)
590 class(
link_t),
pointer:: link, nbor
592 call trace%begin (
'link_t%garbage_collect')
601 link%task%n_needed = link%task%n_needed-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)
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)
623 call garbage%lock%set (
'garbage')
625 call garbage%lock%unset (
'garbage')
626 call link%delete (link)
628 call garbage%lock%set (
'garbage')
629 garbage_n = garbage_n+1
630 link%next => garbage%next
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)
642 call garbage%lock%unset (
'garbage')
645 END SUBROUTINE garbage_collect
651 SUBROUTINE garbage_remove
652 class(
link_t),
pointer:: link, next, prev
654 call trace%begin (
'link_t%garbage_remove')
657 do while (
associated(link))
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)
665 garbage_n = garbage_n-1
666 call link%delete (link)
674 END SUBROUTINE garbage_remove
682 SUBROUTINE delete (self, link)
684 class(
link_t),
pointer:: link
686 class(
link_t),
pointer:: nbor, next
688 call trace%begin (
'link_t%delete')
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
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)
706 deallocate (link%task)
709 call link%lock%unset (
'link_t%delete')
714 END SUBROUTINE delete
719 SUBROUTINE sort_nbors_by_level (self, old_head, new_head)
721 class(
link_t),
pointer:: old_head, new_head
723 class(
link_t),
pointer:: nbor, head, prev, find
725 integer,
save:: itimer=0
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)
733 do while (
associated(nbor))
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)
752 do while (
associated(find))
753 if (find%task%level <= nbor%task%level)
then 766 end subroutine insert
771 class(
link_t),
pointer:: new
772 allocate (new, source=nbor)
773 new%task => nbor%task
774 new%link => nbor%link
776 nbor%task%n_needed = nbor%task%n_needed + 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' 782 if (
associated(prev))
then 787 end subroutine prepend
791 subroutine nbor_print (head)
792 class(
link_t),
pointer:: head, nbor
794 write(io_unit%output,*)
'target: ', self%task%id
795 write(io_unit%output,*)
'sorted nbors:' 797 do while (
associated(nbor))
798 write (io_unit%output,*) nbor%task%id, nbor%task%level
801 end subroutine nbor_print
805 subroutine nbor_check (head)
806 class(
link_t),
pointer:: head, nbor
812 do while (
associated(nbor))
813 if (nbor%task%level > level)
then 815 call nbor_print (head)
816 call io%abort (
'ERROR: sorted nbor list not monotonic')
818 level = nbor%task%level
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')
826 end subroutine nbor_check
827 END SUBROUTINE sort_nbors_by_level
832 SUBROUTINE nbor_info (self, task)
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
847 SUBROUTINE info (self)
849 class(
link_t),
pointer:: nbor
851 call self%task%task_info()
853 do while (
associated(nbor))
854 call nbor%nbor_info (self%task)
Each thread uses a private timer data type, with arrays for start time and total time for each regist...
Support tic/toc timing, as in MATLAB, and accurate wallclock() function. The timing is generally much...
Module with list handling for generic class task_t objects.
The lock module uses nested locks, to allow versatile use of locks, where a procedure may want to mak...
Template module for tasks.