DISPATCH
dispatcher5_mod.f90
1 !===============================================================================
2 !> Dispatcher method that relies on all threads maintaining a "ready queue", with
3 !> tasks ready for updating. Each thread picks the task at the head of the queue,
4 !> and checks all nbors for tasks that are ready, putting them back in the queue.
5 !===============================================================================
7  USE io_mod
8  USE trace_mod
9  USE omp_mod
10  USE timer_mod
11  USE omp_timer_mod
12  USE mpi_mod
13  USE mpi_io_mod
14  USE mpi_mesg_mod
15  USE link_mod
16  USE list_mod
17  USE task_mod
18  USE experiment_mod
19  USE bits_mod
20  USE task_list_mod
21  USE refine_mod
22  USE patch_mod
24  USE task_mesg_mod
25  implicit none
26  private
27  type, public:: dispatcher5_t
28  integer:: verbose=0
29  integer:: n_spawn=0
30  contains
31  procedure:: init
32  procedure:: execute
33  end type
34  integer, save:: verbose=0
35  integer, save:: stalled=0, max_stalled=10000, retry_stalled=100
36  integer, save:: min_nq=2**30
37  logical, save:: do_delay=.false.
38  logical, save:: track_active=.false.
39  type(dispatcher5_t), save:: virtual_list
40  !$omp threadprivate (virtual_list)
41  type(dispatcher5_t), public:: dispatcher5
42 CONTAINS
43 
44 !===============================================================================
45 !> Initialize the task list, by first initializing the list tasks, then making
46 !> neighbor lists, and finally checking if they are ready to execute
47 !===============================================================================
48 SUBROUTINE init (self, name)
49  class(dispatcher5_t):: self
50  character(len=*), optional:: name
51  !.............................................................................
52  class(link_t), pointer:: link
53  integer:: iostat
54  namelist /dispatcher5_params/ verbose, max_stalled, retry_stalled, do_delay
55  !-----------------------------------------------------------------------------
56  ! An optional namelist can be used to turn debugging on
57  !-----------------------------------------------------------------------------
58  call trace%begin('dispatcher5_t%init')
59  call mpi_mesg%init
60  rewind(io%input)
61  read(io%input, dispatcher5_params, iostat=iostat)
62  write (io%output, dispatcher5_params)
63  call trace_end
64 END SUBROUTINE init
65 
66 !===============================================================================
67 !> Execute the task list, updating it until it is empty. With !$omp parallel here,
68 !> everything local to self%update is thread private.
69 !===============================================================================
70 SUBROUTINE execute (self, task_list, test)
71  class(dispatcher5_t):: self
72  type(task_list_t), pointer:: task_list
73  logical:: test
74  !.............................................................................
75  real(8):: sec
76  integer:: dims(4)
77  integer, save:: itimer=0
78  !-----------------------------------------------------------------------------
79  call trace%begin ('dispatcher5_t%execute', itimer=itimer)
80  call startup (task_list)
81  call tic (time=sec)
82  call timer%print()
83  !-----------------------------------------------------------------------------
84  ! Loop over tasks
85  !-----------------------------------------------------------------------------
86  !$omp parallel
87  do while (task_list%na > 0 .and. wallclock() < io%job_seconds)
88  call update_list (task_list, test)
89  if (io%do_stop) call mpi%abort ('stop flag')
90  if (task_list%na == task_list%n_tasks) then
91  !$omp atomic
92  min_nq = min(min_nq,task_list%nq)
93  !$omp end atomic
94  end if
95  end do
96  write (io_unit%log,*) 'thread',omp%thread,' arrived'
97  flush (io_unit%log)
98  !$omp barrier
99  !$omp end parallel
100  call timer%print()
101  call mpi_mesg%diagnostics(1)
102  call toc ('wall time', timer%n_update, time=sec)
103  call mpi%barrier ('end')
104  write (io%output,*) "task list finished, min_nq =", min_nq
105  call trace%end (itimer)
106 END SUBROUTINE execute
107 
108 !===============================================================================
109 !> Update the state of the task list, taking the steps necessary to update the
110 !> head task on the ready_queue, and check for consequences. Two strategies:
111 !>
112 !> 1) The threads pick up tasks from the queue themselves, and put itself or
113 !> other tasks back onto the queue, based on the results of list_t%check_ready
114 !>
115 !> In this case the threads are prevented from messing up for each other by
116 !> using critical regions when manipulating the queue, and by using status bits
117 !> to indicate the state each task is in. These can be 1) in the queue, and
118 !> ready to be updated, 2) not in the queue, and busy, 3) not in the queue, and
119 !> not busy. The 'ready' bit is set while the task is in the queue, and the
120 !> 'busy' but is set while the task is busy being updated. A task should be
121 !> checked for being ready only when in state 3, meaning only when none of the
122 !> two bits are set.
123 !>
124 !> 2) The master thread takes care of picking tasks from the queue, starting an
125 !> OMP thread to update it, and checking for nbors that are ready to be
126 !> updated as a consquence
127 !===============================================================================
128 SUBROUTINE update_list (task_list, test)
129  type(task_list_t), pointer:: task_list
130  logical:: test
131  !.............................................................................
132  class(link_t), pointer:: head, prev
133  class(task_t), pointer:: task, otask
134  class(mesg_t), pointer:: mesg
135  logical:: already_busy, was_refined
136  real(8):: wc
137  real(8), save:: time, otime=0d0
138  integer, save:: oid=0
139  integer:: id, nq
140  integer, save:: itimer=0
141  !.............................................................................
142  call trace%begin('dispatcher5::update_list', itimer=itimer)
143  !-----------------------------------------------------------------------------
144  ! Check incoming MPI, which may free up tasks for execution
145  !-----------------------------------------------------------------------------
146  !call task_list%check_mpi ! check incoming MPI
147  if (mpi%size > 1) then
148  !$omp atomic read
149  nq = task_list%nq
150  !$omp end atomic
151  call mpi_mesg%sent_list%check_sent (nq)
152  end if
153  call mpi_io%iwrite_list%check ! I/O check
154  !-----------------------------------------------------------------------------
155  ! Pick a task off the queue, in a very brief critical region
156  !-----------------------------------------------------------------------------
157  call task_list%lock%set
158  nullify (prev)
159  head => task_list%queue ! queue start
160  if (associated(head) .and. .not.task_list%syncing) then
161  if (verbose > 0) &
162  write(io_unit%log,'(f12.6,i6,i7)') wallclock(), task_list%na, head%task%id
163  !---------------------------------------------------------------------------
164  ! If the patch mem was OMP placed, search ready queue for matching thread
165  !---------------------------------------------------------------------------
166  do while (associated(head))
167  task => head%task
168  if (task%mem_thread==-1 .or. omp%thread == task%mem_thread) exit
169  prev => head
170  head => head%next_time
171  end do
172  !---------------------------------------------------------------------------
173  ! If not found, fall back on first task in queue
174  !---------------------------------------------------------------------------
175  if (.not. associated(head)) then
176  nullify (prev)
177  head => task_list%queue
178  task => head%task ! head task
179  end if
180  task%atime = task%time
181  if (io%verbose > 1) then
182  write (io_unit%log,'(f12.6,2x,a,i4,2x,a,i6,2x,a,1p,g16.6,2x,a,i5)') &
183  wallclock(), 'thread', omp%thread,'takes', task%id, &
184  'time', task%time, 'nq', task%nq
185  flush (io_unit%log)
186  end if
187  !---------------------------------------------------------------------------
188  ! Set the head of the queue to the next task in time. The ready bit needs
189  ! to remain on for now, to prevent other threads from checking this task
190  ! before it is updated. After the update, the clearing of the ready bit
191  ! allows the state of the current task to be evaluated by other threads, as
192  ! well as by the current thread. Locking should be used to allow only a
193  ! single thread and task to check and change the ready bit status, at any
194  ! one time.
195  !
196  ! The busy bit is set on tasks that a thread is updating, to check that a
197  ! a task that has already been taken off the queue by another thread is not
198  ! taken again. This should in principle not be possible, since removing
199  ! the task from the queue is done in a critical region, and removing a
200  ! task can only be done once.
201  !
202  ! A task generats a critical region three times: 1) when taken off the queue,
203  ! 2) when its time info is updated, 3) when it is added back to the queue.
204  !
205  ! To ensure 100% consistency, the task time information should not be
206  ! allowed to change during the testing going on in list_t%check_ready().
207  ! This could possibly be critical, if the fact that a task is / becomes
208  ! ready is missed, because of sychronization issue. Several of the tasks
209  ! that form the nbor list of a task are typically undergoing updates at the
210  ! same time. In rare cases, but only if the update time of task time info
211  ! is not uniquely defined, a task could thus be deemed not ready by the
212  ! last of its nbors that has just been updated, because another task in the
213  ! nbor list had not yet propagated its updated time info.
214  !---------------------------------------------------------------------------
215  already_busy = task%is_set (bits%busy)
216  id = task%id
217  if (.not.already_busy) then
218  call task%set (bits%busy) ! mark task busy
219  if (associated(prev)) then
220  prev%next_time => head%next_time ! skip over
221  else
222  task_list%queue => head%next_time ! chop head off
223  end if
224  call task%clear (bits%ready) ! not in queue
225  if (track_active) &
226  call task_list%queue_active (head)
227  !$omp atomic
228  task_list%nq = task_list%nq-1 ! decrement queue count
229  !$omp end atomic
230  task%nq = task_list%nq ! for info print
231  if (io%verbose >= 0) then
232  if (track_active) then
233  otask => task_list%active%task
234  time = otask%atime
235  if (time < otime) &
236  write (*,'(a,2(f12.6,i6))') 'TIME ERROR: otime, oid, time, id =', otime, oid, time, otask%id
237  !$omp atomic write
238  otime = time
239  !$omp end atomic
240  !$omp atomic write
241  oid = otask%id
242  !$omp end atomic
243  if (omp%master) then
244  write (io_unit%queue,'(f12.6,i6,2f12.6,2i5)') &
245  wallclock(), task%istep, task%time, &
246  otask%atime, task_list%nq, task_list%nac
247  flush (io_unit%queue)
248  end if
249  else
250  if (omp%master) then
251  write (io_unit%queue,'(f12.6,i6,f12.6,2i5)') &
252  wallclock(), task%istep, task%time, &
253  task_list%nq, task_list%nac
254  flush (io_unit%queue)
255  end if
256  end if
257  end if
258  end if
259  !---------------------------------------------------------------------------
260  ! The first time a task is at the head of the ready queue with time =
261  ! sync_time we can be sure that all other tasks are also being upated
262  ! (by other threads) to arrive at this time. We can then temporarily
263  ! halt updating, and wait for this task to finish its update, at a barrier
264  ! where all other ranks are doing the same.
265  !---------------------------------------------------------------------------
266  if (task%time == task_list%sync_next) then
267  task_list%syncing = .true.
268  write (io_unit%mpi,*) task%id,omp%thread, &
269  ' is triggering a sync at t =', task_list%sync_next
270  end if
271  else
272  if (verbose > 0) &
273  write(io_unit%log,'(f12.6,i6,2x,a)') wallclock(), task_list%na, 'no queue'
274  end if
275  call task_list%lock%unset
276  !-----------------------------------------------------------------------------
277  ! As long as we are syncing, skip the update and come back. The on thread
278  ! that hit the sync time last of all threads has set this flag, and will clear
279  ! it as soon as all other ranks have arrived at the same time.
280  !-----------------------------------------------------------------------------
281  if (associated(head)) then
282  if (already_busy) then
283  !$omp critical (io_cr)
284  write (io_unit%output,*) mpi%rank,' WARNING: thread',omp%thread, &
285  ' tried to update busy task', task%id
286  !$omp end critical (io_cr)
287  call trace_end (itimer)
288  return
289  end if
290  if (task%is_set(bits%virtual)) then
291  call unpack (task_list, task%mesg, head)
292  else
293  call update_task (task_list, head, test, was_refined)
294  end if
295  !---------------------------------------------------------------------------
296  ! The task should now again be checked, before it can be returned to the
297  ! queue, and its neighbors should also be checked for return to the queue.
298  ! If the task was turned into a virtual task by the load balance, its virtual
299  ! bit will prevent it being checked, but its nbors still need to be checked
300  !---------------------------------------------------------------------------
301  call task%clear (bits%busy) ! clear busy bit
302  if (.not. was_refined) then
303  call check_nbors (task_list, head) ! any nbors ready?
304  !$omp atomic write
305  stalled = 0
306  !$omp end atomic
307  end if
308  !-----------------------------------------------------------------------------
309  ! If the queue is empty, check all tasks; this may be due to late packages
310  !-----------------------------------------------------------------------------
311  else
312  call check_all (task_list)
313  end if
314  call trace_end (itimer)
315 END SUBROUTINE update_list
316 
317 !===============================================================================
318 !> Update the task
319 !===============================================================================
320 SUBROUTINE update_task (self, head, test, was_refined)
321  class(task_list_t):: self
322  class(link_t), pointer:: head
323  logical:: test
324  logical, optional:: was_refined
325  !.............................................................................
326  class(task_t), pointer:: task
327  real(8):: wc
328  logical:: refined, derefined
329  integer, save:: itimer=0
330  !----------------------------------------------------------------------------
331  ! Check for flag files. If io%out_time is set, set a new out_next.
332  ! If task%time is slightly smaller than a multiple of out_time, then
333  ! out_next will becoe that multiple.
334  !----------------------------------------------------------------------------
335  call trace%begin('dispatcher5::update2', itimer=itimer)
336  task => head%task
337  call io%check_flags
338  if (task%id==io%id_track) then
339  task%track = .not.task%track
340  io%id_track = 0
341  end if
342  !-----------------------------------------------------------------------------
343  ! Check if refinement is needed on the task; if so this will push new tasks
344  ! onto the queue, with the same task time; i.e., to the head of the queue.
345  ! If the task is virtual, it will not be checked by this rank.
346  !-----------------------------------------------------------------------------
347  call refine%check_current(self, head, refined, derefined)
348  if (derefined) then
349  call trace%end (itimer)
350  return
351  end if
352  if (present(was_refined)) then
353  was_refined = refined
354  end if
355  !---------------------------------------------------------------------------
356  ! If the task is frozen (e.g. because it has finished), return
357  !---------------------------------------------------------------------------
358  if (task%is_set (bits%frozen)) then
359  !if (task%iout == 0) call task%output(self%name)
360  ! if a frozen task is set to ready, make it not ready
361  if (task%is_set(bits%ready)) then
362  !$omp atomic
363  self%na = self%na - 1
364  !$omp end atomic
365  end if
366  call trace%end (itimer)
367  return
368  end if
369  !-----------------------------------------------------------------------------
370  ! Download nbor info -- this may be an experiment_t procedure, but if not,
371  ! the call should be answered by a solver-specific procedure (which may or
372  ! may not choose to call the generic patch guard zone handler in tasks/)
373  !-----------------------------------------------------------------------------
374  if (.not.test) &
375  call task%dnload ! download nbor info
376  !-----------------------------------------------------------------------------
377  ! Update the task, whatever that means (may include call to task%output)
378  !-----------------------------------------------------------------------------
379  task%rotated = .false.
380  call task%update ! update the task
381  !$omp atomic
382  mpi_mesg%n_update = mpi_mesg%n_update+1
383  !$omp end atomic
384  if (io%verbose>1) &
385  write (io_unit%log,'(a,i4,2x,a,i7,2x,a,2x,a,i7,2x,a,1p,2g14.6,2x,a,2i5,l3)') &
386  'thread', omp_mythread, 'task', task%id, trim(task%type), &
387  'step', task%istep, 'dt, time:', task%dtime, task%time, &
388  'n, nq', self%n, self%nq, associated(head%nbor)
389  !-----------------------------------------------------------------------------
390  ! The rotate procedure in the generic patch_t module is responsible for
391  ! updating the time, and rotating the memory slots where information about
392  ! previous time steps are saved. Task may signal that they have already done
393  ! the rotate internally, or else are not yet ready to do so, by setting the
394  ! task%rotated flag
395  !-----------------------------------------------------------------------------
396  if (.not.task%rotated) then
397  call task%rotate
398  end if
399  select type (task)
400  class is (patch_t)
401  timer%n_update = timer%n_update + product(task%n)
402  end select
403  call task%info (self%nq, self%na) ! print info on stdout
404  !-----------------------------------------------------------------------------
405  ! If the task is a boundary patch, first check if it should be given to
406  ! another rank. A patch that has been given to another rank becomes
407  ! a virtual patch, and the load balance procedure has already sent those
408  ! of its nbors that became new boundary patches over to relevant ranks,
409  ! while the patch itself is sent here, with bits%virtual+swap_reqest set.
410  !-----------------------------------------------------------------------------
411  if (task%is_set(bits%boundary)) then ! boundary patch?
412  head%task%nq = self%nq ! make sure to pass on
413  if (load_balance%check_load (head)) then ! sell?
414  !$omp atomic
415  self%na = self%na-1
416  !$omp atomic
417  self%nb = self%nb-1
418  !$omp atomic
419  self%nv = self%nv-1
420  call self%count_status ! redundant? (FIXME)
421  end if
422  if (task%id == io%id_debug) &
423  write(io_unit%mpi,*) &
424  'DBG task_list_t%update: calling send_to_vnbors', task%id
425  call self%send_to_vnbors (head) ! send to virtual nbors
426  end if
427  !-----------------------------------------------------------------------------
428  ! Tasks that have finished are subtracted from the task list count but are
429  ! not removed, since their data may be needed by other tasks (including on
430  ! other ranks). They are, however, not added back onto the ready queue.
431  !-----------------------------------------------------------------------------
432  if (task%has_finished()) then ! finished:
433  call task%set (bits%frozen)
434  call load_balance%active (.false.) ! turn off load balancing
435  !$omp atomic
436  self%na = self%na-1
437  end if
438  !-----------------------------------------------------------------------------
439  ! Periodic task syncronization: The first time a task%time is exactly equal
440  ! to load_balance%sync_next, we wait for all ranks to arrive at the same
441  ! time. All tasks within a rank are then also at this time, since as long as
442  ! one has not arrived there yet, the head%ask%time is smaller.
443  !-----------------------------------------------------------------------------
444  if (self%syncing) then
445  write (io_unit%mpi,*) task%id,omp%thread, &
446  ' is waiting on a sync at t =', self%sync_next
447  !call trace%end; call trace%begin ('mpi%barrier', itimer=itimer)
448  call mpi%barrier ('sync')
449  !call trace%end (itimer); call trace%begin('dispatcher0_t%update')
450  write (io_unit%mpi,*) task%id,omp%thread, &
451  ' finished wating on a sync at t =', self%sync_next
452  self%sync_next = self%sync_next + self%sync_time
453  self%syncing = .false.
454  end if
455  task%sync_time = self%sync_next
456  call trace%end (itimer)
457 END SUBROUTINE update_task
458 
459 !===============================================================================
460 !> Check if the link task is ready, and if so, add it to the ready_queue
461 !===============================================================================
462 SUBROUTINE check_ready (self, link)
463  class(list_t):: self
464  class(link_t), pointer:: link
465  class(task_t), pointer:: task
466  class(link_t), pointer:: nbor
467  logical:: ok, debug, debug1
468  integer, save:: itimer=0
469  !-----------------------------------------------------------------------------
470  call trace%begin ('dispatcher5::check_ready', itimer=itimer)
471  task => link%task
472  debug = io%verbose > 1 .or. task%id==io%id_debug
473  !-----------------------------------------------------------------------------
474  ! Only check tasks that are not in the queue, busy, frozen, or external
475  !-----------------------------------------------------------------------------
476  if (task%is_clear(bits%ready+bits%busy+bits%frozen+bits%external)) then
477  if (task%is_set(bits%virtual)) then
478  !$omp critical (irecv_cr)
479  ok = task%mesg%is_complete()
480  if (ok) then
481  if (task%mesg%req==0) then
482  call task%mesg%irecv (task%rank, task%id)
483  end if
484  end if
485  !$omp end critical (irecv_cr)
486  else
487  ok = .true.
488  nbor => link%nbor ! start on nbor list
489  do while (associated (nbor)) ! keep going until end
490  debug1 = nbor%task%id==io%id_debug
491  if (debug1) write(io_unit%log,*) 'DBG check_ready: id, nbor, needed, ahead', &
492  task%id, nbor%task%id, nbor%needed, nbor%task%is_ahead_of(task)
493  if (nbor%needed) then
494  if (nbor%task%is_ahead_of(task)) then ! and is ahead in time
495  if (debug1) &
496  write (io_unit%log,'("DBG list_t%check_ready:",i5,f10.6,a,i6,2f10.6,f6.2,l4)') &
497  task%id, task%time, ' is OK on', nbor%task%id, nbor%task%time, &
498  nbor%task%dtime, nbor%task%grace, nbor%task%is_set(bits%virtual)
499  else ! not ahead in time
500  if (debug1) &
501  write (io_unit%log,'("DBG list_t%check_ready:",i5,f10.6,a,i6,2f10.6,f6.2,l4)') &
502  task%id, task%time, ' failed on', nbor%task%id, nbor%task%time, &
503  nbor%task%dtime, nbor%task%grace, nbor%task%is_set(bits%virtual)
504  ok = .false.
505  exit
506  end if
507  end if
508  nbor => nbor%next ! next nbor
509  end do
510  end if
511  if (ok) then
512  if (debug) &
513  write (io_unit%output,'("list_t%check_ready:",i5,f10.6,a)') &
514  task%id, task%time, ' succeded'
515  call self%queue_by_time (link) ! add task to queue
516  end if
517  end if
518  call trace%end (itimer)
519 END SUBROUTINE check_ready
520 
521 !===============================================================================
522 !> Among a task and its neighbor tasks, move local tasks to ready_queue if they
523 !> are ready. If the ready bit is already set it means the patch has already
524 !> been put in the ready queue, and should not be checked again.
525 !>
526 !> The link pointer and everything it points to are private to this task, and
527 !> are not at this point in time accessible from the ready queue.
528 !===============================================================================
529 SUBROUTINE check_nbors (self, link)
530  class(list_t):: self
531  class(link_t), pointer:: link
532  class(link_t), pointer:: nbor
533  class(task_t), pointer:: task
534  integer, save:: itimer=0
535  !.............................................................................
536  call trace_begin('dispatcher5::check_nbors', itimer=itimer)
537  task => link%task ! main task
538  nbor => link%nbor ! first nbor
539  do while (associated (nbor)) ! keep going until end
540  if (verbose > 1 .or. nbor%task%id==io%id_debug) &
541  write(io_unit%log) &
542  'task', task%id,' needs task ', nbor%task%id, nbor%needs_me
543  call check_ready (self, nbor%link) ! pointer back
544  nbor => nbor%next ! next nbor
545  end do
546  call check_ready (self, link) ! finally check link task
547  call trace_end (itimer)
548 END SUBROUTINE check_nbors
549 
550 !===============================================================================
551 !> Unpack a message, where the MPI tag is the task id. Use that to search
552 !> for the task, apply its unpack method, and check if any nbors become ready.
553 !> This entire operation should be threadsafe, since no other thread should be
554 !> working on the same message and the same patch.
555 !===============================================================================
556 SUBROUTINE unpack (self, mesg, link)
557  class(task_mesg_t):: self
558  class(mesg_t), pointer:: mesg
559  class(link_t), pointer:: link
560  class(link_t), pointer:: link2
561  class(task_t), pointer:: task
562  logical:: failed
563  integer:: id
564  integer, save:: itimer=0
565  !-----------------------------------------------------------------------------
566  call trace%begin ('dispatcher5::unpack', itimer=itimer)
567  if (mesg%nbuf < 40) then
568  call load_balance%unpack (mesg%buffer)
569  return
570  end if
571  !$omp critical (unpack_cr)
572  task => link%task
573  failed = .false.
574  !-----------------------------------------------------------------------------
575  ! Guard against lingering extra messages to a swapped patch
576  !-----------------------------------------------------------------------------
577  if (task%is_set (bits%boundary)) then
578  write (io_unit%log,'(f12.6,2x,a,i9,3x,5l1)') wallclock(), &
579  'task_mesg_mod::unpack ERROR, received mpi_mesg for boundary task:', task%id, &
580  task%is_set(bits%internal), &
581  task%is_set(bits%boundary), &
582  task%is_set(bits%virtual), &
583  task%is_set(bits%external), &
584  task%is_set(bits%swap_request)
585  failed = .true.
586  end if
587  if (task%is_set (bits%ready)) then
588  write (io_unit%log,'(f12.6,2x,a,i9,3x,5l1)') wallclock(), &
589  'task_mesg_mod::unpack ERROR, received mpi_mesg for task with ready bit:', &
590  task%id, &
591  task%is_set(bits%internal), &
592  task%is_set(bits%boundary), &
593  task%is_set(bits%virtual), &
594  task%is_set(bits%external), &
595  task%is_set(bits%swap_request)
596  failed = .true.
597  end if
598  !---------------------------------------------------------------------------
599  ! Unpack a patch message (which includes swapping the roles of boundary bits).
600  ! Since an already existing patch may, at any one time, be under investigation
601  ! by check_nbors, it must be protected by a critical region (or an OMP
602  ! lock) while it is being updated here
603  !---------------------------------------------------------------------------
604  id = task%id
605  call task%unpack (mesg)
606  if (mpi_mesg%debug) &
607  write (io_unit%log,'(f12.6,2x,a,i9,1p,e18.6)') wallclock(), &
608  'unpk: id, time =', task%id, task%time
609  if (id /= mesg%id) then
610  write(io%output,'(i6,i4,2x,a,3i6)') mpi%rank, omp%thread, &
611  'unpack ERROR: wrong mesg%id', id, task%id, mesg%id
612  write(io_unit%log,'(f12.6,i6,i4,2x,a,4i6)') wallclock(), mpi%rank, &
613  omp%thread, 'unpack ERROR: wrong mesg%id', mesg%sender, id, task%id, mesg%id
614  end if
615  if (.not. failed) then
616  !$omp atomic
617  mpi_mesg%n_unpk = mpi_mesg%n_unpk+1
618  !$omp end atomic
619  !---------------------------------------------------------------------------
620  ! If the boundary+swap bits are set, this is a task that has just changed
621  ! rank, and it needs to have its nbor relations re-initialized. This includes
622  ! resorting (removing + re-adding) the nbor's nbor lists in rank order.
623  ! FIXME: The load balancing steps should be checked for threadsafe operation
624  !---------------------------------------------------------------------------
625  if (task%is_set(bits%swap_request) .and. task%is_set(bits%boundary)) then
626  self%na = self%na+1; self%nb = self%nb+1; self%nv = self%nv-1
627  call self%init_nbors (link)
628  call task%clear (bits%swap_request+bits%ready)
629  call self%update_nbor_status (link)
630  call self%count_status
631  if (verbose>1) &
632  write(io%output,'(f12.6,2x,a,i6,a,i9,a,i6)') &
633  wallclock(),'LB: rank',mpi%rank,' given patch',task%id,' by',mesg%sender
634  if (verbose>0) &
635  write (io_unit%log,*) 'task_mesg_t%unpack: swapped virtual to boundary:', task%id
636  !---------------------------------------------------------------------------
637  ! If the link has no nbors it is a newly created virtual task. Does it need
638  ! an nbor list? At least we can use the nbor list to check that the link is
639  ! in its nbors nbor lists. A new virtual task (where no task existed) means
640  ! that some nbor of it has changed from internal to boundary, which will be
641  ! checked by the test_nbor_status call below, but only if an nbor list exists.
642  !---------------------------------------------------------------------------
643  !else if (.not.associated(link%nbor)) then
644  else if (task%is_set(bits%swap_request) .and. task%is_set(bits%virtual)) then
645  if (verbose>0) &
646  write (io_unit%log,*) 'task_mesg_t%unpack: new virtual patch:', task%id
647  self%nv = self%nv+1
648  call self%init_nbors (link)
649  call task%clear (bits%swap_request+bits%ready)
650  call self%update_nbor_status (link)
651  call self%count_status
652  end if
653  end if
654  !$omp end critical (unpack_cr)
655  call trace%end (itimer)
656 END SUBROUTINE unpack
657 
658 !===============================================================================
659 !> Start-up preparation; initialize task message, look for updateable tasks
660 !===============================================================================
661 SUBROUTINE startup (task_list)
662  class(task_list_t):: task_list
663  class(link_t), pointer:: link
664  class(task_t), pointer:: task
665  !-----------------------------------------------------------------------------
666  call trace%begin ('dispatcher5::startup')
667  !-----------------------------------------------------------------------------
668  ! Initialize the task message, and request the first package
669  !-----------------------------------------------------------------------------
670  link => task_list%head
671  do while (associated(link))
672  task => link%task
673  if (task%is_set (bits%virtual)) then
674  call task%allocate_mesg
675  task%wc_last = wallclock()
676  call task%mesg%irecv (task%rank, task%id)
677  end if
678  link => link%next
679  end do
680  !-----------------------------------------------------------------------------
681  ! Look for tasks ready to update
682  !-----------------------------------------------------------------------------
683  link => task_list%head
684  do while (associated(link))
685  call link%task%clear(bits%ready)
686  call check_ready (task_list, link)
687  link => link%next
688  end do
689  call timer%print()
690  task_list%n_tasks = task_list%na
691  !-----------------------------------------------------------------------------
692  ! This may not be needed, but might avoid initial load balance excursions
693  !-----------------------------------------------------------------------------
694  call mpi%barrier ('task_list%execute')
695  call trace%end()
696 END SUBROUTINE startup
697 
698 !===============================================================================
699 !> Among a task and its neighbor tasks, move local tasks to ready_queue if they
700 !> are ready, and send task data to non-locals.
701 !===============================================================================
702 SUBROUTINE check_all (list)
703  class(list_t):: list
704  class(link_t), pointer:: link
705  integer, save:: itimer=0
706  !.............................................................................
707  call trace_begin('dispatcer5::check_all', itimer=itimer)
708  call list%lock%set
709  link => list%head
710  do while (associated (link)) ! keep going until end
711  call link%task%clear (bits%ready)
712  call check_ready (list, link) ! link ready?
713  link => link%next
714  end do
715  call list%lock%unset
716  call trace_end (itimer)
717 END SUBROUTINE check_all
718 
719 END MODULE
Each thread uses a private timer data type, with arrays for start time and total time for each regist...
Definition: timer_mod.f90:11
Module for handling blocking and non-blocking MPI parallel I/O to a single file. The module is initia...
Definition: mpi_io_mod.f90:31
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.
Definition: list_mod.f90:4
Template module for patches, which adds pointers to memory and mesh, and number of dimensions and var...
Definition: patch_mod.f90:6
This module handles checking max change between neighboring points. Each instance of it needs an inde...
Definition: refine_mod.f90:168
Message handling for task lists. Some of the methods are only used by dispatcher0_t, so should perhaps be moved over to that file.
Task list data type, with methods for startup and updates. Message handling is inherited from the tas...
Definition: io_mod.f90:4
Keep track of neighbor ranks and their loads, by sending and receiving short messages, storing the info in a linked list.
Template module for tasks.
Definition: task_mod.f90:4
Dispatcher method that relies on all threads maintaining a "ready queue", with tasks ready for updati...