21 character(len=64):: name=
'' 22 class(
link_t),
pointer:: head => null()
23 class(
link_t),
pointer:: tail => null()
24 class(
link_t),
pointer:: queue => null()
25 class(
link_t),
pointer:: active => null()
34 real(8):: lc(3) = +huge(0d0)
35 real(8):: uc(3) = -huge(0d0)
36 real(8):: llc(3) = +huge(0d0)
37 real(8):: urc(3) = -huge(0d0)
38 real(8):: position(3) = 0.0_8
39 real(8):: size(3) = 1.0_8
40 integer:: n_behind=0, n_check=0, n_ready=0, n_nbor=0
46 character(len=4):: kind=
'list' 47 logical:: face_nbors=.false.
48 logical:: detailed_timer=.false.
51 procedure:: init_bdries
53 procedure:: append_task
54 procedure:: append_link
55 generic:: append => append_task, append_link
56 procedure:: prepend_link
57 procedure:: remove_task
58 procedure:: remove_link
59 generic:: remove => remove_task, remove_link
60 procedure:: remove_and_reset
61 procedure:: update_counts
62 procedure:: count_status
63 procedure:: reset_status
64 procedure:: check_nbors
65 procedure:: check_ready
67 procedure:: resend_bdry
68 procedure:: check_oldest
69 procedure:: check_queue
70 procedure:: add_new_link
71 procedure:: init_nbors
72 procedure:: set_init_nbors
73 procedure:: init_nbor_nbors
74 procedure:: check_nbor_nbors
75 procedure:: refresh_nbors
76 procedure:: init_all_nbors
77 procedure:: remove_parents
79 procedure:: consistency
80 procedure:: qconsistency
81 procedure:: aconsistency
82 procedure:: statistics
83 procedure:: append_list
84 procedure:: add_by_quality
85 procedure:: queue_by_time
86 procedure:: queue_active
87 procedure:: remove_active
88 procedure:: print_queue
89 procedure:: print_queue_until
90 procedure:: print_queue_times
91 procedure:: print => print_list
92 procedure:: print_tasks
93 procedure,
nopass:: check_nbor_list
95 procedure:: update_nbor_status
96 procedure:: update_status
97 procedure:: send_to_vnbors
98 procedure:: test_nbor_status
101 integer,
dimension(:),
allocatable:: sequence
102 integer,
parameter:: mnbor=100
103 type(
list_t),
public:: list
110 SUBROUTINE init (self, name)
112 character(len=*),
optional:: name
114 call trace%begin (
'list_t%init')
115 if (
present(name))
then 117 write (io_unit%log,*)
'init_list: ', name
118 call self%lock%init (name(1:4))
120 write (io_unit%log,*)
'init_list: list_t' 121 call self%lock%init (
'list_t')
124 if (.not.
allocated(sequence))
then 125 allocate (sequence(0:mpi%size-1))
136 SUBROUTINE reset (self)
138 class(
link_t),
pointer:: link, old
139 class(
task_t),
pointer:: task
141 call trace%begin (
'list_t%reset '//self%name)
143 do while (
associated(link))
145 if (
associated(link))
then 162 SUBROUTINE append_task (self, task, nbor, needed, needs_me)
164 class(
link_t),
pointer,
optional:: nbor
165 logical,
optional:: needed, needs_me
166 class(
task_t),
pointer:: task
167 class(
link_t),
pointer:: link
169 call trace%begin (
'list_t%append_task '//self%name)
173 if (
present(nbor)) link%nbor => nbor
174 if (
present(needed)) link%needed = needed
175 if (
present(needs_me)) link%needs_me = needs_me
176 call self%append_link (link)
178 END SUBROUTINE append_task
183 SUBROUTINE append_link (self, link)
185 class(
link_t),
pointer:: link
186 class(
task_t),
pointer:: task
187 class(*),
pointer:: anon
188 logical,
save:: first_time=.true.
190 call trace%begin (
'list_t%append_link ')
192 if (self%verbose > 2) &
193 write (io%output,*) wallclock(),
' thread',omp%thread,
' wait for tasklist(2)' 194 call self%lock%set (
'list_t%append_link')
195 if (self%verbose > 2) &
196 write (io%output,*) wallclock(),
' thread',omp%thread,
' locked tasklist(2)' 198 if (
associated(self%tail))
then 199 link%prev => self%tail
200 link%prev%next => link
206 if (
associated(link%task))
then 213 call io%abort(
'append_link: no task associated')
219 if (self%verbose > 2) &
220 print *,
'list_t%append: (1) n =', trim(self%name), self%n, link%task%id
221 call self%update_counts (link, +1)
222 if (self%verbose > 1) &
223 print *,
'list _t%append:(2) n =', trim(self%name), self%n, link%task%id
224 call self%lock%unset (
'list_t%append_link')
225 if (self%verbose > 2) &
226 write (io%output,*) wallclock(),
' thread',omp%thread,
' unlocked tasklist(2)' 228 END SUBROUTINE append_link
233 SUBROUTINE prepend_link (self, link)
235 class(
link_t),
pointer:: link
236 class(
task_t),
pointer:: task
237 class(*),
pointer:: anon
238 logical,
save:: first_time=.true.
240 call trace%begin (
'list_t%prepend_link '//self%name)
242 call self%lock%set (
'list_t%prepend_link')
244 if (
associated(self%head))
then 245 link%next => self%head
246 link%next%prev => link
252 if (
associated(link%task))
then 258 call self%update_counts (link, +1)
260 call io%abort(
'prepend_link: no task associated')
265 call self%lock%unset (
'list_t%prepend_link')
267 END SUBROUTINE prepend_link
274 SUBROUTINE remove_and_reset (self, link)
276 class(
link_t),
pointer:: link
279 call trace%begin (
'list_t%remove_and_reset')
285 call link%task%set (bits%remove)
289 if (link%task%is_set (bits%boundary))
then 290 call self%send_to_vnbors (link)
293 if (self%verbose > 0)
then 294 write (io_unit%log,
'(f12.6,2x,a,i6,2l3)') &
295 wallclock(),
'list_t%remove_and_reset: id =', link%task%id, &
296 link%task%is_set(bits%boundary), link%task%is_set(bits%virtual)
299 call self%lock%set (
'remove_and_reset')
300 call self%remove_link (link)
301 call self%lock%unset (
'remove_and_reset')
302 call self%check_nbors (link)
303 call self%set_init_nbors (link)
305 timer%levelpop (link%task%level) = &
306 timer%levelpop (link%task%level) - 1
307 call link%garbage_collect (link)
309 END SUBROUTINE remove_and_reset
314 SUBROUTINE remove_link (self, link)
316 class(
link_t),
pointer:: link, next
317 class(
task_t),
pointer:: task
319 call trace%begin (
'list_t%remove_link '//self%name)
324 if (
associated(next))
then 326 next%prev => link%prev
330 self%tail => link%prev
336 if (
associated(link%prev))
then 338 link%prev%next => next
348 call self%update_counts (link, -1)
350 END SUBROUTINE remove_link
358 SUBROUTINE update_counts (self, link, delta)
360 class(
link_t),
pointer:: link
361 integer:: delta, n, na
366 if (link%task%is_set (bits%virtual))
then 368 self%nv = self%nv + delta
369 else if (link%task%is_set (bits%boundary))
then 371 self%nb = self%nb + delta
373 self%na = self%na + delta
374 else if (link%task%is_set (bits%internal))
then 376 self%ni = self%ni + delta
378 self%na = self%na + delta
383 if (self%verbose > 0)
then 386 call self%count_status ()
387 if (n /= self%n .or. na /= self%na)
then 388 write (stdout,
'(a,2(2i6,2x))') &
389 'list_t%update_counts WARNING: inconsistent counts', &
390 n, self%n, na, self%na
395 END SUBROUTINE update_counts
400 SUBROUTINE count_status (self, label)
402 character(len=*),
optional:: label
403 class(
link_t) ,
pointer:: link, nbor
404 integer:: n, ni, nb, nv, ne, nf
405 integer,
save:: itimer=0
407 call trace%begin (
'list_t%count_status', itimer=itimer)
408 call self%lock%set (
'count_status')
409 nb=0; ni=0; nv=0; ne=0; nf=0; n = 0
411 do while (
associated(link))
413 if (link%task%is_set(bits%frozen )) nf = nf+1
414 if (link%task%is_set(bits%boundary)) nb = nb+1
415 if (link%task%is_set(bits%virtual )) nv = nv+1
416 if (link%task%is_set(bits%internal)) ni = ni+1
417 if (link%task%is_set(bits%external)) ne = ne+1
424 if (self%verbose > 0)
then 425 if (
present(label))
then 426 write (io_unit%log,
'(1x,a,6i6,2x,a)') &
427 'list_t%count_status: n[ibveaf] = ', &
428 self%ni, self%nb, self%nv, self%ne, self%na, nf, label
430 write (io_unit%log,
'(1x,a,6i6,2x,a)') &
431 'list_t%count_status: n[ibveaf] = ', &
432 self%ni, self%nb, self%nv, self%ne, self%na, nf
435 self%na = ni + nb - nf
437 call self%lock%unset (
'count_status')
438 call trace%end (itimer)
439 END SUBROUTINE count_status
444 SUBROUTINE reset_status (self, check)
446 logical,
optional:: check
448 class(
link_t),
pointer:: link, nb
449 integer:: n_internal, n_boundary, n_virtual, n_external, n_frozen
453 call trace%begin (
'list_t%reset_status')
454 if (self%verbose > 1) &
455 write (io_unit%output,*)
'reset_status' 461 call self%lock%set (
'reset_status')
466 do while (
associated(link))
467 if (link%task%rank == mpi%rank)
then 471 call link%task%set(bits%internal)
472 call link%task%clear(bits%boundary+bits%virtual+bits%external)
477 call link%task%set(bits%external)
478 call link%task%clear(bits%internal+bits%boundary+bits%virtual)
484 do while (
associated(nb))
485 if (
present(check))
then 486 flags(:,1) = [nb%needed, nb%needs_me, nb%download]
488 call link%task%nbor_relations (nb%task, nb%needed, nb%needs_me, nb%download)
489 if (
present(check))
then 490 flags(:,2) = [nb%needed, nb%needs_me, nb%download]
491 if (.not.all(flags(:,2) .eqv. flags(:,1)))
then 492 write (stderr,*) link%task%id, flags(:,1)
493 write (stderr,*) nb%task%id, flags(:,2)
495 call io%abort (
'nbor_relations() returned value inconsistent with initial values')
500 if (self%verbose > 1) &
501 write(io_unit%log,
'(a,i6,i4,3x,3l1)') &
502 'reset_status: task, rank, IBV =', link%task%id, link%task%rank, &
503 link%task%is_set(bits%internal), &
504 link%task%is_set(bits%boundary), &
505 link%task%is_set(bits%virtual)
506 n_internal = n_internal + merge(1,0,link%task%is_set(bits%internal))
507 n_boundary = n_boundary + merge(1,0,link%task%is_set(bits%boundary))
508 n_virtual = n_virtual + merge(1,0,link%task%is_set(bits%virtual ))
509 n_external = n_external + merge(1,0,link%task%is_set(bits%external))
510 n_frozen = n_frozen + merge(1,0,link%task%is_set(bits%frozen ))
519 self%na = n_internal+n_boundary-n_frozen
520 self%n = n_internal+n_boundary+n_virtual
521 if (self%verbose > 1)
then 522 write (io_unit%log,
'(5(a,i7,5x))') &
524 'n_internal:', n_internal, &
525 'n_boundary:', n_boundary, &
526 'n_virtual:' , n_virtual, &
527 'n_frozen:' , n_frozen
531 call self%lock%unset (
'reset_status')
533 END SUBROUTINE reset_status
538 SUBROUTINE check_nbor_nbors (self, link)
540 class(
link_t),
pointer:: link
542 class(
link_t),
pointer:: nbor
544 call trace%begin (
'list_t%check_nbor_nbors')
546 do while (
associated(nbor))
547 call self%check_nbors (nbor%link)
550 call self%check_ready(link)
552 END SUBROUTINE check_nbor_nbors
565 SUBROUTINE check_nbors (self, link)
567 class(
link_t),
pointer:: link
568 class(
link_t),
pointer:: nbor, nbors
569 class(
task_t),
pointer:: task
571 integer,
save:: itimer=0
575 call trace%begin(
'list_t%check_nbors', itimer=itimer)
580 do while (
associated (nbor))
581 if (nbor%task%id==io%id_debug) print *, &
582 'task', task%id,
' needs task ', nbor%task%id, nbor%needs_me
583 if (nbor%needs_me)
then 584 if (self%verbose > 1) &
585 write (io_unit%log,*) wallclock(), task%id,
'checks nbor', nbor%task%id
586 call self%check_ready (nbor%link, lock=.true.)
588 if (self%verbose > 1) &
589 write (io_unit%log,*) wallclock(), task%id,
'no need to check', nbor%task%id
599 if (task%is_clear (bits%virtual+bits%external))
then 600 call self%check_ready (link)
602 call trace%end (itimer)
604 END SUBROUTINE check_nbors
610 SUBROUTINE check_all (self, repair)
612 logical,
optional:: repair
614 class(
link_t),
pointer:: link, nbor
615 integer,
save:: itimer=0
618 call trace%begin(
'list_t%check_all', itimer=itimer)
619 write (io_unit%log,*) wallclock(),
'check_all: phase 1', &
620 self%nq,
associated(self%queue)
621 if (
present(repair))
then 626 do while (
associated (link))
627 if (link%task%is_clear (bits%virtual+bits%external))
then 628 call self%check_ready (link)
629 if (self%nq > nq)
then 630 write (io_unit%log,*)
'check_all found', link%task%id, link%task%time
632 do while (
associated(nbor))
633 write (io_unit%log,*)
'nbor, time =', nbor%task%id, nbor%task%time, &
634 nbor%needed, nbor%needs_me, nbor%download
642 write (io_unit%log,*) wallclock(),
'check_all: done ', &
643 self%nq,
associated(self%queue)
644 if (.not.
associated(self%queue))
then 645 write (io_unit%log,*)
'check_all: phase 2, clearing ready bits' 647 do while (
associated (link))
648 if (link%task%is_clear (bits%virtual+bits%external))
then 649 if (link%task%is_set (bits%ready))
then 650 write (io_unit%log,*)
'clearing ready bit on', link%task%id
651 call link%task%clear (bits%ready)
653 call self%check_ready (link)
658 call trace%end (itimer)
659 END SUBROUTINE check_all
664 SUBROUTINE resend_bdry (self)
666 class(
link_t),
pointer:: link
668 call trace%begin (
'list_t%resend_bdry')
669 call self%lock%set (
'resend_bdry')
671 do while (
associated(link))
672 if (link%task%is_set (bits%boundary))
then 673 call self%send_to_vnbors (link)
677 call self%lock%unset (
'resend_bdry')
679 END SUBROUTINE resend_bdry
684 SUBROUTINE check_oldest (self)
686 class(
link_t),
pointer:: link, oldest, oldestv, oldestnb, nbor
687 real(8):: told, toldv
688 integer,
save:: phase=1
690 call trace%begin(
'list_t%check_oldest ')
691 write (io_unit%log,*)
'check_oldest: phase 1', wallclock()
699 do while (
associated (link))
700 if (link%task%is_clear (bits%frozen))
then 701 if (link%task%is_set(bits%virtual))
then 702 if (link%task%time < toldv)
then 703 toldv = link%task%time
707 if (link%task%time < told)
then 708 told = link%task%time
715 if (
associated(oldest))
then 716 write (io_unit%log,*)
'oldest active is ', oldest%task%id , told, &
717 oldest%task%is_set(bits%ready), oldest%task%is_set(bits%busy)
719 write (stderr,*)
'STALLED: oldest active not found ' 722 if (
associated(oldestv))
then 723 write (io_unit%log,*)
'the oldest virtual task is ', oldestv%task%id, toldv
724 write (io_unit%log,*)
'it was last unpacked at', oldestv%task%unpack_time
727 if (
associated(oldest))
then 729 write (io_unit%log,2) oldest%task%id, oldest%task%time, oldest%task%rank, oldest%task%level, &
730 oldest%needed, oldest%needs_me, oldest%task%is_set(bits%boundary), oldest%task%is_set(bits%virtual)
731 2
format(i6,f12.6,2i4,5l3,f12.6)
732 write (io_unit%log,*)
'nbor list:' 733 do while (
associated(nbor))
734 write (io_unit%log,2) nbor%task%id, nbor%task%time, nbor%task%rank, nbor%task%level, &
735 nbor%needed, nbor%needs_me, nbor%task%is_set(bits%boundary), nbor%task%is_set(bits%virtual), &
736 nbor%task%is_ahead_of (oldest%task), nbor%task%unpack_time
739 call oldest%task%clear (bits%ready+bits%busy)
740 call self%queue_by_time (oldest)
741 write (io_unit%log,*)
'task queued' 743 write (io_unit%log,*)
'check_oldest: phase 1 done' 752 if (
associated(oldest))
then 753 write (io_unit%log,*)
'check_oldest: phase 2',
associated(oldest)
754 write (io_unit%log,1)
'the oldest local task is', oldest%task%id, &
755 'rank', oldest%task%rank, oldest%task%time, &
756 oldest%task%is_set (bits%virtual), oldest%task%is_set (bits%external)
759 do while (
associated(link))
760 if (link%task%time < told)
then 764 write (io_unit%log,1) &
765 'nbor', link%task%id,
'rank', link%task%rank, link%task%time, &
766 link%task%is_set(bits%boundary), link%task%is_set (bits%virtual)
767 1
format (1x,a,i9,3x,a,i6,1p,e16.6,2l3)
771 write (io_unit%log,
'(f12.6,2(3x,a,i8,i6,f12.6,3x,4l1),3i5)') wallclock(), &
772 'oldest:', oldest%task%id, oldest%task%rank, oldest%task%time, &
773 oldest%task%is_set(bits%internal), oldest%task%is_set(bits%boundary), &
774 oldest%task%is_set(bits%virtual), oldest%task%is_set(bits%external), &
775 'nbor:', oldestnb%task%id, oldestnb%task%rank, oldestnb%task%time, &
776 oldestnb%task%is_set(bits%internal), oldestnb%task%is_set(bits%boundary), &
777 oldestnb%task%is_set(bits%virtual), oldestnb%task%is_set(bits%external), &
778 self%nq, sent_list%n, recv_list%n, unpk_list%n
780 if (
associated(oldestv))
then 781 write (io_unit%log,*)
'the oldest virtual task is ', oldestv%task%id, oldestv%task%time
782 write (io_unit%log,*)
'check_oldest: phase 3',
associated(oldestv)
783 write (io_unit%log,1)
'the oldest virtual task is', oldestv%task%id, &
784 'rank', oldestv%task%rank, oldestv%task%time, &
785 oldest%task%is_set (bits%virtual), oldest%task%is_set (bits%external)
787 do while (
associated(link))
788 write (io_unit%log,1) &
789 'nbor', link%task%id,
'rank', link%task%rank, link%task%time, &
790 link%task%is_set(bits%boundary), link%task%is_set (bits%virtual)
796 END SUBROUTINE check_oldest
801 SUBROUTINE check_ready (self, link, lock)
803 class(
link_t),
pointer:: link
804 logical,
optional:: lock
806 class(
task_t),
pointer:: task
807 class(
link_t),
pointer:: nbor
808 integer:: ignore, unit
809 integer,
save:: itimer=0
816 ignore = bits%ready + bits%busy + bits%remove + bits%virtual + bits%frozen
817 if (task%is_set (ignore)) &
819 if (self%detailed_timer) &
820 call trace%begin (
'list_t%check_ready', itimer=itimer)
826 if (
present(lock) .and. omp_lock%links) &
827 call link%lock%set (
'check_ready')
831 ignore = bits%frozen + bits%remove
834 do while (
associated (nbor))
838 if (nbor%needed .and. nbor%task%is_clear(ignore))
then 839 if (.not. nbor%task%is_ahead_of(task))
then 841 task%n_failed = task%n_failed+1
842 if (self%verbose > 1 .or. task%n_failed > 10000)
then 843 if (self%verbose > 1)
then 860 if (
present(lock) .and. omp_lock%links) &
861 call link%lock%unset (
'check_ready')
865 call self%queue_by_time (link)
867 if (self%detailed_timer) &
868 call trace%end (itimer)
869 END SUBROUTINE check_ready
874 SUBROUTINE consistency (self, link, i)
876 class(
link_t),
pointer:: link
877 class(
task_t),
pointer:: task
878 class(
link_t),
pointer:: nbor
879 integer:: n, id1=0, id2=0, i
881 if (self%debug < 2)
return 882 call trace%begin (
'list_t%consistency',1)
883 call self%lock%set (
'list_t%consistency')
887 if (
associated(nbor)) id1 = nbor%task%id
888 do while (
associated (nbor))
894 if (n /= link%task%n_nbors)
then 895 write (io_unit%log,*) task%id,
'ERROR: n, nbors', n, id1, id2, i
899 call self%lock%unset (
'list_t%consistency')
901 END SUBROUTINE consistency
907 SUBROUTINE qconsistency (self, ident)
909 class(
link_t),
pointer:: link
910 class(
task_t),
pointer:: task, prev
911 class(
link_t),
pointer:: nbor
912 integer:: n, id1=0, id2=0, ident
916 call trace%begin (
'list_t%qconsistency',4)
918 if (io%verbose>2)
then 920 do while (
associated(link))
921 print *,
'task list: id, time =', link%task%id, link%task%time
924 print *,
'nq:', self%nq
928 do while (
associated(link))
930 if (n > self%nq)
exit 933 if (io%verbose>2)
then 934 print *,
'queue: n, id, time =', n, link%task%id, link%task%time, &
935 link%task%is_set (bits%ready), link%task%is_set (bits%busy)
937 if (task%time < time)
then 938 write (io_unit%log,
'(a,i4,2(i9,1p,g15.6,3x))') &
939 'ERROR: queue out of order ident, prev%id, time, task%id', ident, prev%id, time, task%id, task%time
942 link => link%next_time
944 if (n /= self%nq)
then 945 write (io_unit%log,*) &
946 'ERROR: qconsistency ident, n, nq, ident =', ident, n, self%nq
949 do while (
associated(link))
951 write (io_unit%log,*) n, link%task%id, link%task%time
952 link => link%next_time
953 if (n > self%nq+1)
exit 958 END SUBROUTINE qconsistency
964 SUBROUTINE aconsistency (self, ident)
966 class(
link_t),
pointer:: link
967 class(
task_t),
pointer:: task, prev
968 class(
link_t),
pointer:: nbor
969 integer:: n, id1=0, id2=0, ident
973 call trace%begin (
'list_t%aconsistency',4)
976 if (
associated(link))
then 977 time = link%task%atime
979 link => link%next_active
982 do while (
associated(link))
985 if (n > self%nac)
exit 986 if (task%atime < time)
then 987 write (io_unit%log,
'(a,i4,2(i9,1p,g15.6,3x),i5)') &
988 'ERROR: active queue out of order ident, prev%id, time, task%id, task%atime =', &
989 ident, prev%id, time, task%id, task%atime, self%nac
992 do while (
associated(link))
994 write (io_unit%log,*) n, link%task%id, link%task%atime
995 link => link%next_active
1001 link => link%next_active
1003 if (n /= self%nac)
then 1004 write (io_unit%log,*) &
1005 'ERROR: aconsistency ident, n, nac =', ident, n, self%nac
1008 do while (
associated(link))
1010 write (io_unit%log,*) n, link%task%id, link%task%atime
1011 link => link%next_active
1012 if (n > self%nac+2)
exit 1016 END SUBROUTINE aconsistency
1021 SUBROUTINE init_nonleaf (self)
1023 class(
link_t),
pointer:: link, scan
1024 class(
link_t),
pointer:: nbor
1028 call trace%begin(
'list_t%init_nonleaf ')
1029 call self%lock%set (
'list_t%init_nonleaf')
1036 do while (
associated(link))
1038 do while (
associated(scan))
1039 if (.not.
associated(scan,link).and. &
1040 .not.scan%task%is_set(bits%not_leaf))
then 1041 if (scan%task%overlaps(link%task))
then 1042 if (scan%task%level==link%task%level-1)
then 1043 if (all(abs(scan%task%position-link%task%position) < scan%task%size*0.55d0))
then 1044 call scan%task%set (bits%not_leaf)
1046 write (io_unit%log,*)
'patch', link%task%id,
' parent:', scan%task%id
1055 call self%lock%unset (
'list_t%init_nonleaf')
1057 END SUBROUTINE init_nonleaf
1062 SUBROUTINE add_new_link (self, link)
1064 class(
link_t),
pointer:: link
1066 class(
link_t),
pointer:: nbor
1067 class(
task_t),
pointer:: task
1069 call trace%begin (
'list_t%add_new_task')
1082 call self%init_nbors (link)
1083 call self%append (link)
1084 if (link%task%is_set (bits%boundary)) &
1085 call self%send_to_vnbors (link)
1089 if (task%is_clear (bits%virtual))
then 1091 timer%levelpop (task%level) = &
1092 timer%levelpop (task%level) + 1
1098 call self%set_init_nbors (link)
1104 call self%check_ready (link)
1106 END SUBROUTINE add_new_link
1112 SUBROUTINE init_nbors (self, link)
1114 class(
link_t),
pointer:: link
1116 class(
link_t),
pointer:: nbor, scan, new_head, new_sort, old_head, old_sort, nbors
1119 integer,
save:: itimer=0
1121 call trace%begin(
'list_t%init_nbors ', itimer=itimer)
1122 nullify (new_head, new_sort)
1124 call self%lock%set (
'init_nbors')
1126 do while (
associated(scan))
1134 if (.not.
associated(scan,link) .and.
associated(scan%task))
then 1135 overlaps = scan%task%overlaps(link%task) &
1136 .and. scan%task%level <= link%task%level+1
1140 if (io%verbose>2 .or. link%task%id==io%id_debug) &
1141 write (io_unit%log,
'(a,3(i6,2(3f7.4,1x)),2x,2l2)') &
1143 link%task%id, link%task%position, link%task%size, &
1144 scan%task%id, scan%task%position, scan%task%size, &
1145 0, scan%task%distance (link%task), self%size, &
1146 overlaps, scan%task%is_set(bits%virtual)
1154 nbor%task => scan%task
1156 call link%add_nbor_by_rank (new_head, nbor)
1157 call link%task%nbor_relations (nbor%task, nbor%needed, &
1158 nbor%needs_me, nbor%download)
1164 call self%lock%unset (
'init_nbors')
1166 if (self%verbose > 1 .or. link%task%id == io%id_debug) &
1167 write(io_unit%log,
'(a,i6,i4,3x,3l1)') &
1168 'init_nbors: link, rank, IBV =', link%task%id, link%task%rank, &
1169 link%task%is_set(bits%internal), &
1170 link%task%is_set(bits%boundary), &
1171 link%task%is_set(bits%virtual)
1172 if (self%verbose > 2 .or. link%task%id == io%id_debug) &
1173 write (io_unit%log,*) &
1174 'added ', n_add,
' neighbors to', link%task%id, &
1175 link%task%is_set(bits%boundary), link%task%is_set(bits%virtual)
1181 call link%sort_nbors_by_level (new_head, new_sort)
1182 call link%lock%set (
'init_nbors')
1183 old_head => link%nbor
1184 old_sort => link%nbors_by_level
1185 link%nbor => new_head
1186 link%nbors_by_level => new_sort
1187 call link%lock%unset (
'init_nbors')
1191 call link%remove_nbor_list (old_head)
1192 call link%remove_nbor_list (old_sort)
1194 link%task%n_nbors = n_add
1201 call link%task%clear (bits%init_nbors)
1202 call trace%end (itimer)
1203 END SUBROUTINE init_nbors
1210 SUBROUTINE set_init_nbors (self, link)
1212 class(
link_t),
pointer:: link, nbor
1214 call trace%begin (
'list_t%set_init_nbors')
1215 if (self%verbose > 0) &
1216 write (io_unit%log,*) &
1217 'set_init_nbors: id =', link%task%id
1219 do while (
associated(nbor))
1220 call nbor%task%set (bits%init_nbors)
1221 if (self%verbose > 1)
then 1222 write (io_unit%log,*)
'bits%init_nbors set ', nbor%task%id, nbor%task%istep
1227 END SUBROUTINE set_init_nbors
1236 SUBROUTINE init_nbor_nbors (self, link)
1238 class(
link_t),
pointer:: link
1240 class(
link_t),
pointer:: nbor, nbors
1244 call trace%begin(
'list_t%init_nbor_nbors')
1245 call link%lock%set (
'init_nbnbs')
1246 call self%init_nbors (link)
1247 call self%check_nbors (link)
1248 call link%copy_nbor_list (link%nbor, nbors)
1249 call link%lock%unset (
'init_nbnbs')
1255 do while (
associated(nbor))
1256 if (nbor%link%task%is_set (bits%boundary)) &
1257 call nbor%link%task%set (bits%init_nbors)
1258 if (self%verbose > 0) &
1259 write (io_unit%log,*)
'init_nbor_nbors: id =', nbor%link%task%id
1260 call self%init_nbors (nbor%link)
1261 call self%check_nbors (nbor%link)
1264 call link%remove_nbor_list (nbors)
1266 END SUBROUTINE init_nbor_nbors
1273 SUBROUTINE refresh_nbors (self, link)
1275 class(
link_t),
pointer:: link
1277 class(
link_t),
pointer:: nbor1, nbor2
1279 integer,
save:: itimer=0
1281 call trace%begin(
'list_t%refresh_nbors ', itimer=itimer)
1284 do while (ok .and.
associated(nbor1))
1285 ok = ok .and. nbor1%task%overlaps(link%task)
1294 print *, link%task%id,
'list_t%refresh_nbors: init_nbprs' 1295 call self%init_nbors (link)
1296 call self%check_nbors (link)
1298 call trace%end (itimer)
1299 END SUBROUTINE refresh_nbors
1306 SUBROUTINE init_all_nbors (self)
1308 class(
link_t),
pointer:: link
1309 integer:: i, i0, i1, i2, n=0, nv=0, nb=0
1311 integer,
save:: itimer=0
1313 call trace%begin(
'list_t%init_all_nbors', itimer=itimer)
1314 call timer%tic (time)
1315 call init_nonleaf (self)
1316 call self%reset_status
1317 call self%count_status
1318 i2 = self%n/omp%nthreads + 1
1324 do while (
associated(link))
1325 if (i >= i0 .and. i<i1)
then 1326 call self%init_nbors (link)
1334 call timer%toc (
'init_all_nbors', 1, time)
1335 call trace%end (itimer)
1336 END SUBROUTINE init_all_nbors
1341 SUBROUTINE remove_parents (self)
1343 class(
link_t),
pointer:: link, scan, parent
1345 call trace%begin(
'list_t%remove_parents')
1346 call self%lock%set (
'remove_parent')
1348 do while (
associated(link))
1350 do while (
associated(scan))
1356 if (scan%task%level==link%task%level-1)
then 1357 if (all(abs(scan%task%position-link%task%position) < scan%task%size*0.55d0))
then 1362 if (
associated(parent))
then 1363 write (*,
'(2(1x,a,i9,5x))') &
1364 'removing parent task', parent%task%id,
'level', parent%task%level
1365 io%nwrite = io%nwrite - 1
1366 io%ntask = io%ntask - 1
1367 call parent%remove_from_nbors (parent)
1368 call self%remove_link (parent)
1373 call self%lock%unset (
'remove_parent')
1375 END SUBROUTINE remove_parents
1379 FUNCTION intpos (self, task1, task2)
RESULT (out)
1381 class(
task_t),
pointer:: task1
1382 class(
task_t),
pointer,
optional:: task2
1386 if (
present(task2))
then 1387 dist = task1%position - task2%position
1388 dist = modulo(dist + 0.5*self%size, self%size) - 0.5*self%size
1389 out = floor(dist/task1%size + 0.5)
1391 out = floor(task1%position/task1%size + 0.5)
1397 SUBROUTINE statistics (self)
1399 write (io_unit%log,
'(a,3(5x,a,i6))')
'output_experiment:', &
1400 'n_ready:', self%n_ready, &
1401 'n_check:', self%n_check, &
1402 'n_nbor:' , self%n_nbor
1403 END SUBROUTINE statistics
1407 SUBROUTINE append_list (self, task_list)
1409 class(
list_t),
pointer:: task_list
1410 class(
link_t),
pointer:: link
1413 call trace%begin (
'list_t%append_list')
1414 if (
associated(self%tail))
then 1415 self%tail%next => task_list%head
1417 self%head => task_list%head
1419 self%tail => task_list%tail
1420 self%n = self%n + task_list%n
1423 do while (
associated(link))
1428 write (io_unit%log,*) trim(self%name)//
': OK append of '//task_list%name
1430 write (io_unit%log,*) trim(self%name)//
': inconsistent append of '//task_list%name
1433 END SUBROUTINE append_list
1436 SUBROUTINE remove_task (self, task)
1438 class(
task_t),
pointer:: task
1439 class(
link_t),
pointer:: link, prev
1441 call trace%begin(
'list_t%remove_task')
1442 if (self%verbose > 2) &
1443 write (io%output,*) wallclock(),
' thread',omp%thread,
' wait for tasklist(3)' 1444 call self%lock%set (
'remove_task')
1445 if (self%verbose > 2) &
1446 write (io%output,*) wallclock(),
' thread',omp%thread,
' locked tasklist(3)' 1449 do while (
associated(link))
1450 if (link%task%id == task%id)
then 1451 if (
associated(prev))
then 1452 prev%next => link%next
1454 self%head => link%next
1461 print*,
'ERROR: failed to remove from task list, task', task%id
1466 call self%count_status()
1467 call self%lock%unset (
'remove_task')
1468 if (self%verbose > 1) &
1469 write (io%output,*) wallclock(),
' thread',omp%thread,
' locked tasklist(3)' 1471 END SUBROUTINE remove_task
1491 SUBROUTINE queue_by_time (self, this)
1493 class(
link_t),
pointer:: this
1497 if (self%verbose > 2) &
1498 write (io%output,*) wallclock(),
' thread',omp%thread,
' waitfor tasklist(4)' 1499 call self%lock%set (
'queue_by_time')
1500 if (self%verbose > 2) &
1501 write (io%output,*) wallclock(),
' thread',omp%thread,
' locked tasklist(4)' 1502 call real_queue_by_time (self, this, error)
1504 io%do_trace = .true.
1505 verbose = io%verbose
1507 call self%qconsistency (999)
1508 call self%check_all (repair=.true.)
1509 call real_queue_by_time (self, this, error)
1511 print *,
'ERROR: queue repair failed' 1514 io%verbose = verbose
1515 io%do_trace = .false.
1517 call self%lock%unset (
'queue_by_time')
1518 if (self%verbose > 2) &
1519 write (io%output,*) wallclock(),
' thread',omp%thread,
' unlocked tasklist(4)' 1520 END SUBROUTINE queue_by_time
1522 SUBROUTINE real_queue_by_time (self, this, error)
1524 class(
link_t),
pointer:: this
1526 class(
link_t),
pointer:: next, prev, link
1527 class(
task_t),
pointer:: task
1528 integer,
save:: itimer=0
1535 if (task%is_set (bits%virtual + bits%frozen))
then 1536 write(stderr,*) mpi%rank, omp%thread, &
1537 'ERROR: tried to queue virtual or frozen task, VF =', &
1538 task%is_set(bits%virtual), task%is_set(bits%frozen)
1539 write(io_unit%log,*) mpi%rank, omp%thread, &
1540 'ERROR: tried to queue virtual or frozen task, VF =', &
1541 task%is_set(bits%virtual), task%is_set(bits%frozen)
1544 if (task%time > io%end_time)
then 1545 write (io_unit%mpi,*) mpi%rank, omp%thread, &
1546 'ERROR: tried to queue a task beyond end_time, VF =', &
1547 task%id, task%time, io%end_time, &
1548 task%is_set(bits%virtual), task%is_set(bits%frozen)
1552 write (io_unit%mpi,*)
'task list:' 1553 do while (
associated(link))
1556 if (task%time > io%end_time)
then 1558 write (io_unit%mpi,*) i, j, task%id, task%time, &
1559 task%is_set(bits%ready), task%is_set(bits%busy), &
1560 task%is_set(bits%boundary), task%is_set(bits%virtual), &
1561 task%is_set(bits%frozen),
associated(link%next_time)
1567 write (io_unit%mpi,*)
'queue:' 1568 do while (
associated(link))
1571 write (io_unit%mpi,*) j, task%id, task%time, &
1572 task%is_set(bits%ready), task%is_set(bits%busy), &
1573 task%is_set(bits%boundary), task%is_set(bits%virtual), &
1574 task%is_set(bits%frozen),
associated(link%next_time)
1575 link => link%next_time
1577 write (io_unit%mpi,*)
'na =', self%na
1578 call self%reset_status()
1579 call self%count_status(
'overtime')
1586 if (self%detailed_timer) &
1587 call trace%begin (
'list_t%queue_by_time ', itimer=itimer)
1589 mpi_mesg%n_ready = mpi_mesg%n_ready+1
1595 if (task%is_clear (bits%ready+bits%busy))
then 1596 call task%set(bits%ready)
1598 write (io_unit%log,
'(f12.6,i5,2x,a,i9,a,f12.6,2x,a,i5)') wallclock(), omp%thread, &
1599 'list_t%queue_by_time: adding task', task%id,
' at time', task%time, &
1604 do while (
associated(next))
1606 if (nit > self%nq)
then 1607 print *,
'ERROR: hang in queue_by_time, nit =', nit
1609 if (self%detailed_timer) &
1610 call trace%end (itimer)
1613 if (
associated(next%task, task))
then 1614 write (io_unit%log,*) omp_mythread,
' WARNING: task', task%id,
' is already in ready queue' 1616 else if (next%task%time > task%time)
then 1617 this%next_time => next
1618 if (
associated(prev))
then 1619 if (io%verbose > 1)
then 1620 write (io_unit%output,
'(i4,2x,a,i6,a,i6,i5,1p,3g16.6)') &
1621 omp%thread,
'task',task%id,
' in ready queue between',prev%task%id,next%task%id, &
1622 prev%task%time, this%task%time, next%task%time
1623 write (io_unit%log,
'(i4,2x,a,i6,a,i6,i5,1p,3g16.6)') &
1624 omp%thread,
'task',task%id,
' in ready queue between',prev%task%id,next%task%id, &
1625 prev%task%time, this%task%time, next%task%time
1628 prev%next_time => this
1634 if (io%verbose > 1)
then 1635 write (io_unit%output,*)
'task',task%id,
' at ready queue head',self%nq
1636 write (io_unit%log,*)
'task',task%id,
' at ready queue head',self%nq
1644 next => next%next_time
1647 if (
associated(prev))
then 1648 if (io%verbose > 1)
then 1649 write (io_unit%output,*)
'task',task%id,
' in ready queue after',prev%task%id,self%nq
1650 write (io_unit%log,*)
'task',task%id,
' in ready queue after',prev%task%id,self%nq
1652 prev%next_time => this
1654 if (io%verbose > 1)
then 1655 write (io_unit%output,*)
'task',task%id,
' at ready queue head',self%nq
1656 write (io_unit%log,*)
'task',task%id,
' at ready queue head',self%nq
1660 nullify (this%next_time)
1662 call self%remove_active (this)
1668 else if (io%verbose > 1)
then 1669 if (io%verbose > 2) &
1670 print
'(i6,a,i5,a,i6,1p,e15.6)', mpi%rank,
' INFO: thread',omp%thread, &
1671 ' found ready bit in queue_by_time for task', task%id, task%time
1672 write (io_unit%log,*) wallclock(),
' INFO: thread',omp%thread, &
1673 ' found ready bit in queue_by_time for task', task%id, task%time
1676 if (self%detailed_timer) &
1677 call trace%end (itimer)
1678 END SUBROUTINE real_queue_by_time
1682 SUBROUTINE queue_active (self, this)
1684 class(
link_t),
pointer:: this
1685 class(
link_t),
pointer:: next, prev
1686 class(
task_t),
pointer:: task
1687 integer,
save:: itimer=0
1689 if (self%detailed_timer) &
1690 call trace%begin (
'list_t%queue_active ', itimer=itimer)
1693 task%atime = task%time
1695 write (io_unit%log,
'(1x,i4,2x,a,i9,a,f10.5,i5,l4)') omp%thread, &
1696 'list_t%queue_active: adding task', task%id,
' at time', task%atime, &
1697 self%nac,
associated(self%active)
1700 self%nac = self%nac+1
1702 do while (
associated(next))
1703 if (
associated(next%task, task))
then 1704 write (io_unit%log,*) omp_mythread,
' WARNING: task', task%id,
' is already in active queue' 1706 else if (next%task%atime > task%atime)
then 1707 this%next_active => next
1708 if (
associated(prev))
then 1709 if (io%verbose > 1)
then 1710 write (io_unit%log,*)
'task',task%id,
' in active queue after',prev%task%id,self%nac
1712 prev%next_active => this
1715 if (io%verbose > 1)
then 1716 write (io_unit%log,*)
'task',task%id,
' at ready queue head',self%nac
1722 next => next%next_active
1724 if (.not.
associated(next))
then 1725 if (
associated(prev))
then 1726 if (io%verbose > 1)
then 1727 write (io_unit%log,*)
'task',task%id,
' at active queue tail',prev%task%id,self%nac
1729 prev%next_active => this
1731 if (io%verbose > 1)
then 1732 write (io_unit%log,*)
'task',task%id,
' at active queue head',self%nac
1736 nullify (this%next_active)
1738 call self%aconsistency (1)
1740 if (self%detailed_timer) &
1741 call trace%end (itimer)
1742 END SUBROUTINE queue_active
1747 SUBROUTINE remove_active (self, this)
1749 class(
link_t),
pointer:: this
1750 class(
link_t),
pointer:: next, prev
1752 if (.not.
associated(self%active))
return 1753 call trace%begin (
'list_t%remove_active')
1757 do while (
associated(next))
1758 if (
associated(next%task, this%task))
then 1759 if (
associated(prev))
then 1760 prev%next_active => next%next_active
1762 self%active => next%next_active
1764 self%nac = self%nac-1
1765 if (io%verbose > 1) &
1766 write (io_unit%mpi,*)
'remove_active: id, nac =', this%task%id, self%nac
1770 next => next%next_active
1774 END SUBROUTINE remove_active
1779 SUBROUTINE add_by_quality (self, this)
1781 class(
link_t),
pointer:: this
1782 class(
link_t),
pointer:: next, prev
1784 call trace%begin (
'list_t%add_by_quality')
1785 call self%lock%set (
'add_by_quality')
1788 do while (
associated(next))
1789 if (
associated(next%task,this%task))
then 1790 write (io_unit%log,*)
'ERROR: Trying to add task', this%task%id,
' which is already there' 1793 if (next%task%level >= this%task%level)
then 1798 if (
associated(prev))
then 1811 if (
associated(prev))
then 1823 call self%count_status()
1824 call self%lock%unset (
'add_by_quality')
1826 END SUBROUTINE add_by_quality
1831 SUBROUTINE check_queue (self)
1833 class(
link_t),
pointer:: link
1837 call self%lock%set (
'check_queue')
1841 do while (
associated(link))
1842 if (link%task%time < previous) &
1843 write (io_unit%log,*)
'ERROR: queue out of order at', link%task%id, link%task%time, &
1845 previous = link%task%time
1846 link => link%next_time
1849 if (nq /= self%nq)
write (io_unit%log,*)
'ERROR: inconsistent number of tasks in queue', nq, self%nq
1850 call self%lock%unset (
'check_queue')
1851 END SUBROUTINE check_queue
1856 SUBROUTINE insert (self, old, new)
1858 class(
link_t),
pointer:: old, new
1860 call trace%begin (
'list_t%insert '//self%name)
1861 call self%lock%set (
'insert')
1862 if (
associated(old%prev))
then 1863 new%prev => old%prev
1864 new%prev%next => new
1869 new%next%prev => new
1873 call self%count_status()
1874 call self%lock%unset (
'insert')
1876 END SUBROUTINE insert
1881 SUBROUTINE print_queue (self)
1883 class(
link_t) ,
pointer:: link, nbor
1885 call self%print_queue_times (
'print_queue')
1886 END SUBROUTINE print_queue
1891 SUBROUTINE print_queue_until (self, task)
1894 class(
link_t) ,
pointer:: link, nbor
1896 call self%lock%set (
'print_queue_until')
1898 if (io%master)
write (io_unit%log,*)
'print_queue_until:' 1899 do while (
associated(link))
1900 write (io_unit%log,
'("queue: id, t0, t, t0-t =",i7,1p,3e12.3)') &
1901 link%task%id, task%time, link%task%time, task%time-link%task%time
1902 if (link%task%id==task%id)
exit 1903 link => link%next_time
1905 call self%lock%unset (
'print_queue_until')
1906 END SUBROUTINE print_queue_until
1911 SUBROUTINE print_queue_times (self, label)
1913 character(len=*),
optional:: label
1914 class(
link_t) ,
pointer:: link, nbor
1916 call self%lock%set (
'print_queue_times')
1918 if (
present(label))
then 1919 write (io_unit%log,*)
'print_queue_times: '//trim(label)
1921 write (io_unit%log,*)
'print_queue_times:' 1923 do while (
associated(link))
1924 write (io_unit%log,
'("queue: id, time =",i7,1p,g14.5,l5)') link%task%id, link%task%time, &
1925 link%task%is_set(bits%ready)
1926 link => link%next_time
1928 call self%lock%unset (
'print_queue_times')
1929 write (io_unit%log,*)
'done' 1930 END SUBROUTINE print_queue_times
1934 SUBROUTINE print_list (self, label)
1936 character(len=*),
optional:: label
1937 class(
link_t),
pointer:: link, prev
1938 class(
task_t),
pointer:: task
1939 character(len=32):: type
1941 call trace%begin (
'list_t%print')
1943 write (io_unit%log,*)
'list_t%print: ',trim(self%name), self%n
1944 call self%lock%set (
'print_list')
1946 do while (
associated(link))
1964 write (io_unit%log,
'(a,i9,f10.6,3x,3f10.6,i4,i6,l5,2x,a)') &
1965 'list_t%print:', task%id, task%time, task%position, task%status, &
1966 task%n_nbors,
associated(link%nbor),
type 1969 call self%lock%unset (
'print_list')
1971 END SUBROUTINE print_list
1976 SUBROUTINE print_tasks (self, label)
1978 character(len=*),
optional:: label
1979 class(
link_t) ,
pointer:: link, nbor
1982 call trace%begin (
'list_t%print_tasks')
1983 if (
present(label))
then 1984 write (io_unit%log,
'(a,i8,":")')
'task_list: '//trim(label), self%n
1986 write (io_unit%log,
'(a,i8,":")')
'task_list', self%n
1989 do while (
associated(link))
1990 if (io%verbose < 3)
then 1991 write (io_unit%log,
'(i8,g15.6,3x,3l1)') link%task%id, link%task%time, &
1992 link%task%is_set(bits%ready), link%task%is_set(bits%boundary), &
1993 link%task%is_set(bits%virtual)
1995 call link%print_nbors
1999 write (io_unit%log,*)
'' 2001 END SUBROUTINE print_tasks
2007 SUBROUTINE init_bdries (self)
2010 class(
link_t),
pointer:: link
2011 class(
task_t),
pointer:: patch
2012 real(8):: position(3), limit(3)
2014 call trace%begin(
'task_list_t%init_bdries')
2016 do while (
associated(link))
2020 call patch%init_bdries
2022 self%lc = min(self%lc, link%task%position)
2023 self%uc = max(self%uc, link%task%position)
2024 self%llc = min(self%llc, link%task%position-0.5000000001_8*link%task%size)
2025 self%urc = max(self%urc, link%task%position+0.5000000001_8*link%task%size)
2031 function formatted (task)
result (out)
2033 character(len=6):: out
2035 if (task%boundaries%is_set(bits%xl)) out(1:1) =
'T' 2036 if (task%boundaries%is_set(bits%xu)) out(2:2) =
'T' 2037 if (task%boundaries%is_set(bits%yl)) out(3:3) =
'T' 2038 if (task%boundaries%is_set(bits%yu)) out(4:4) =
'T' 2039 if (task%boundaries%is_set(bits%zl)) out(5:5) =
'T' 2040 if (task%boundaries%is_set(bits%zu)) out(6:6) =
'T' 2041 end function formatted
2042 END SUBROUTINE init_bdries
2047 SUBROUTINE check_nbor_list (link, label, verbose)
2049 character(len=*):: label
2050 integer,
optional:: verbose
2051 class(
link_t),
pointer:: nbor
2052 class(
task_t),
pointer:: task
2055 do while (
associated(nbor))
2056 if (
associated(nbor%link))
then 2057 if (
associated(nbor%task))
then 2061 if (.not.
associated(task%link,nbor%link))
then 2062 print *, label, link%task%id, task%id, &
2063 'ERROR: nbor%link, task%link not associated' 2067 print *, label, link%task%id,
'ERROR: nbor%task not associated' 2070 print *, label, link%task%id,
'ERROR: nbor%link not associated' 2072 if (
present(verbose))
then 2073 task => nbor%link%task
2076 print *, link%task%id, nbor%task%id, task%id,
associated(task%link,nbor%link)
2081 END SUBROUTINE check_nbor_list
2087 SUBROUTINE give_to (self, link, rank)
2089 class(
link_t),
pointer:: link
2095 call link%task%clear (bits%boundary)
2096 call link%task%set (bits%virtual+bits%swap_request)
2097 link%task%rank = rank
2105 call self%update_nbor_status (link)
2107 call self%test_nbor_status (link)
2108 END SUBROUTINE give_to
2115 SUBROUTINE update_nbor_status (self, link)
2117 class(
link_t),
pointer:: link, nbor, this
2120 call trace%begin (
'link_mod::update_nbor_status')
2121 call link%lock%set (
'update_nbor_status')
2124 do while (
associated(nbor))
2126 write (io_unit%log,*)
'update_nbor_status:', nbor%task%id, &
2127 nbor%task%is_set(bits%boundary), nbor%task%is_set(bits%virtual)
2128 status = nbor%task%status
2129 call nbor%link%remove_nbor (link)
2132 this%task => link%task
2133 call nbor%link%add_nbor_by_rank (link%nbor, this)
2134 call self%update_status (nbor%link)
2135 if (nbor%task%is_set (bits%boundary).and.iand(status,bits%boundary)==0)
then 2137 write (io_unit%log,*)
'sending new bdry task',nbor%task%id,
' to vnbors' 2138 if (.not.nbor%task%is_clear (bits%virtual))
then 2139 call nbor%task%clear (bits%virtual)
2140 write (io_unit%log,*)
'WARNING: needed to clear virtual bit(1)' 2142 call nbor%task%set (bits%swap_request)
2143 nbor%task%rank = mpi%rank
2144 call self%send_to_vnbors (nbor%link)
2145 call nbor%link%task%clear (bits%swap_request + &
2152 write (io_unit%log,*)
'update_nbor_status: id =', link%task%id,
associated(link)
2153 status = link%task%status
2154 call self%update_status (link)
2155 if (link%task%is_set (bits%boundary).and.iand(status,bits%boundary)==0)
then 2157 write (io_unit%log,*)
'sending new bdry task',link%task%id,
' to vnbors' 2158 if (.not.nbor%task%is_clear (bits%virtual))
then 2159 write (io_unit%log,*)
'WARNING: needed to clear virtual bit(2)' 2160 call nbor%task%clear (bits%virtual)
2162 call nbor%task%set (bits%swap_request)
2163 nbor%task%rank = mpi%rank
2164 call self%send_to_vnbors (link)
2165 call nbor%task%clear (bits%swap_request)
2167 call link%lock%unset (
'update_nbor_status')
2169 END SUBROUTINE update_nbor_status
2176 SUBROUTINE update_status (self, link)
2179 class(
link_t),
pointer:: nbor
2181 call link%lock%set (
'update_status')
2183 if (link%task%rank == mpi%rank)
then 2184 do while (
associated(nbor))
2185 if (nbor%task%rank /= mpi%rank)
then 2186 call link%task%set (bits%boundary)
2187 call link%task%clear (bits%internal+bits%external+bits%virtual)
2189 write (io_unit%log,*)
' set to boundary id =', link%task%id
2194 call link%task%set (bits%internal)
2195 call link%task%clear (bits%boundary+bits%external+bits%virtual)
2197 write (io_unit%log,*)
' set to internal id =', link%task%id,
associated(link%nbor)
2199 do while (
associated(nbor))
2200 if (nbor%task%rank == mpi%rank)
then 2201 call link%task%set (bits%virtual)
2202 call link%task%clear (bits%internal+bits%external+bits%boundary)
2204 write (io_unit%log,*)
' set to virtual id =', link%task%id
2209 call link%task%set (bits%external)
2210 call link%task%clear (bits%internal+bits%boundary+bits%virtual)
2213 write (io_unit%log,*)
' set to external id =', link%task%id
2215 call link%lock%unset (
'update_status')
2216 END SUBROUTINE update_status
2227 SUBROUTINE send_to_vnbors (self, link)
2229 class(
link_t),
pointer:: link
2230 class(
link_t),
pointer:: nbor
2231 class(
task_t),
pointer:: task, nbtask
2232 class(
mesg_t),
pointer:: mesg
2233 character(len=24):: label
2234 integer:: ierr, rank, tag, seq
2235 integer,
save:: itimer=0
2238 if (task%is_clear (bits%boundary))
then 2239 write (stdout,*) mpi%rank, omp%thread, &
2240 'ERROR: trying to send non-boundary task', task%id
2243 if (task%is_set (bits%virtual))
then 2244 write (stdout,*) mpi%rank, omp%thread, &
2245 'ERROR: trying to send virtual task', task%id
2249 call trace%begin(
'list_t%send_to_vnbors', itimer=itimer)
2250 if (task%id == io%id_debug) &
2251 write(io%output,*)
'DBG link_t%send_to_vnbors: id, rank =', &
2258 call task%pack (mesg)
2260 if (mpi_mesg%uniq_mesg .and. mpi_mesg%tag_type == 1)
then 2261 task%seq = task%seq + 1
2262 tag = mod(task%seq,100) + 100*task%id
2276 do while (
associated(nbor))
2278 if (nbtask%rank/=mpi%rank .and. nbtask%rank/=rank)
then 2280 if (mpi_mesg%uniq_mesg .and. mpi_mesg%tag_type == 2)
then 2282 sequence(rank) = sequence(rank)+1
2283 seq = sequence(rank)
2285 tag = mod(seq,100) + 100*task%id
2287 if (task%logging > 1)
then 2288 write (label,
'(a,i4,i8)')
'vnbor ', rank, tag
2289 call task%log (label)
2291 call mesg%send (rank, tag=tag)
2293 if (self%verbose > 0 .or. task%id == io%id_debug)
then 2294 write (io_unit%mpi,
'(f12.6,2x,a,i9,1p,e18.6,i9,2x,a,i5,2x,5l1)') &
2295 wallclock(),
'send_to_vnbors: sent', &
2296 mesg%id, task%time, tag,
'to', rank, &
2297 task%is_set (bits%internal), &
2298 task%is_set (bits%boundary), &
2299 task%is_set (bits%virtual), &
2300 task%is_set (bits%external), &
2301 task%is_set (bits%swap_request)
2310 call mpi_mesg%sent (mesg)
2311 call task%clear (bits%swap_request)
2313 call trace%end (itimer)
2314 END SUBROUTINE send_to_vnbors
2319 SUBROUTINE test_nbor_status (self, link)
2322 class(
link_t),
pointer:: nbor
2324 write (io_unit%log,*)
'test_nbor_status: link', link%task%id
2325 call test_status (link)
2327 do while (
associated(nbor))
2328 call test_status (nbor%link)
2331 END SUBROUTINE test_nbor_status
2336 SUBROUTINE test_status (self)
2338 class(
link_t),
pointer:: nbor
2339 integer:: status, test, n
2341 write (io_unit%log,*)
'test_status: link', self%task%id
2342 if (self%task%rank == mpi%rank)
then 2343 status = bits%internal
2345 status = bits%external
2348 do while (
associated(nbor))
2349 if (nbor%task%rank /= mpi%rank .and. status==bits%internal)
then 2350 status = bits%boundary
2351 else if (nbor%task%rank == mpi%rank .and. status==bits%external)
then 2352 status = bits%virtual
2356 test = iand(self%task%status,bits%internal+bits%boundary+bits%virtual+bits%external)
2357 if (status /= test)
then 2358 write (io_unit%log,
'(i9,2x,a,i6,2(2x,4l1))') self%task%id,
'inconsistent:', &
2360 self%task%is_set(bits%internal), &
2361 self%task%is_set(bits%boundary), &
2362 self%task%is_set(bits%virtual) , &
2363 self%task%is_set(bits%external), &
2364 iand(status,bits%internal)/=0, &
2365 iand(status,bits%boundary)/=0, &
2366 iand(status,bits%virtual )/=0, &
2367 iand(status,bits%external)/=0
2370 do while (
associated(nbor))
2372 write (io_unit%log,
'(2i9,2x,a,2i6)') self%task%id, nbor%task%id, &
2373 'inconsistent ranks', self%task%rank, nbor%task%rank
2376 if (n==0)
write (io_unit%log,*) self%task%id,
' inconsistent bits: has no nbors' 2378 END SUBROUTINE test_status
2383 SUBROUTINE info (self)
2385 class(
link_t),
pointer:: link, nbor
2386 class(
task_t),
pointer:: task, nbtask
2388 call trace%begin (
'task_list_t%info')
2390 do while (
associated(link))
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.
Template module for patches, which adds pointers to memory and mesh, and number of dimensions and var...
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.