DISPATCH
dispatcher6_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 !> The method is similar to method5, except the state of each task is given by
6 !> the value of task_t%state, rather than by status bits in task_t%status, and
7 !> locks are used to protect on the one hand the ready queue, and on the other
8 !> hand each individual task.
9 !>
10 !> READY QUEUE: The ready queue consists of links starting with task_list%queue,
11 !> and continuing with link%next_time. Any change to one of these quantities
12 !> requires that the thread acquires the task_list%lock. All threads will be
13 !> competing to do that, so the locked time must be as short as possible.
14 !>
15 !> TASK LOCKS: Each task can change state from stat 0 (dormant) to state 1
16 !> ready to become updated, state 2 (busy = being updated), state 3 (just updated),
17 !> and state 9 (finished). Each such change of state must be done by first
18 !> acquiring the task%lock, changing the state variable, and releasing the lock.
19 !> The state of task needs to be checked in various contexts, and to get a unique
20 !> answer on such a check the task%lock must be acquired during the check. Some
21 !> of these checks are anyway done in connection with changing the state, so the
22 !> lock is anyway already acquired. Other checks (e.g. the check on whether the
23 !> task is ahead or behind another task) do not occur in connection with a change
24 !> of state, and then the task%lock must be explicitly acquired before the check,
25 !> and then released. Each lock set/unset may take of the order 0.1-0.3 micro-
26 !> seconds, so up to several dozen of these can be done without significantly
27 !> increasing the computing time, since each task update typically uses several
28 !> tens of milliseconds. A task is typically acquired as many times as there are
29 !> nbors in the nbor list (or at most that many times), so there should be no
30 !> chance that the set/unset of locks could take significant time, and since a
31 !> specific task%lock has no impact on other tasks, this should be scalable to
32 !> any number of threads per process.
33 !>
34 !> When should a task be locked? The most conservative choice is that a task is
35 !> locked the entire time it is being updated, so while being in state 2, while
36 !> the least conservative choice is that a task is locked only when it changes
37 !> state, and when the state is being tested. The task cycle consists of a long
38 !> dormant time, a short (e.g. few percent) update time, and the very brief times
39 !> when it changes state. The main outside reference to task data is when the
40 !> task time is compared to that of another task. The task time should only be
41 !> updated in locked state, going from state 2 to state 3. While the task is in
42 !> state 0, 1, or 2, it may still have a sufficiently advanced time to be able
43 !> to serve guard zones, so there is no reason to exclude any state, or require
44 !> a particular state, while it is being tested. It just needs to be locked by
45 !> the thread performing the comparison.
46 !>
47 !> When a task is used as a source for guard zone loading it may be wise and
48 !> conservative to lock it, so the time slots cannot be rotated during the guard
49 !> zone date acquisition. In principle this may not be necessary, at least if
50 !> one does NOT make use of the indirect addressing array iit((), which is being
51 !> changed during a rotate. However, it may still be risky, since a time slot
52 !> that is being used during guard zone interpolations might be overwritten with
53 !> new data during the computations, if the task is not locked. Since the time
54 !> a task is needed as a source for guard zone values is only 5-10% of the update
55 !> time, locking it briefly during this time may be ok. There are, however, about
56 !> 26 such accesses per time step, so that could start to become a problem, if
57 !> the source task is locked during the whole interpolation time. A better
58 !> approach is to lock briefly, compute the memory slot needed, check if there is
59 !> a risk that it will become overwritten (this would be the case only if the
60 !> slot is nr 1 in the iit() array, and keep the task locked only if this is the
61 !> case.
62 !===============================================================================
64  USE io_mod
65  USE trace_mod
66  USE omp_mod
67  USE omp_lib
68  USE timer_mod
69  USE omp_timer_mod
70  USE mpi_mod
71  USE mpi_io_mod
72  USE mpi_mesg_mod
73  USE link_mod
74  USE list_mod
75  USE task_mod
76  USE experiment_mod
77  USE bits_mod
78  USE task_list_mod
79  USE refine_mod
80  USE patch_mod
82  USE task_mesg_mod
83  !USE rt_mod
84  implicit none
85  private
86  type, public:: dispatcher6_t
87  integer:: verbose=0
88  integer:: n_spawn=0
89  contains
90  procedure:: init
91  procedure:: execute
92  end type
93  integer, save:: n_state(0:4)=0
94  integer, save:: d_state(0:4)=0
95  integer, save:: verbose=0
96  integer, save:: stalled=0, max_stalled=10000, retry_stalled=100
97  integer, save:: min_nq=2**30
98  logical, save:: do_delay=.false.
99  logical, save:: track_active=.false.
100  type(dispatcher6_t), save:: virtual_list
101  !$omp threadprivate (virtual_list)
102  type(dispatcher6_t), public:: dispatcher6
103 CONTAINS
104 
105 !===============================================================================
106 !> Initialize the task list, by first initializing the list tasks, then making
107 !> neighbor lists, and finally checking if they are ready to execute
108 !===============================================================================
109 SUBROUTINE init (self, name)
110  class(dispatcher6_t):: self
111  character(len=*), optional:: name
112  !.............................................................................
113  class(link_t), pointer:: link
114  logical:: queue_unpack, send_priv, recv_active, recv_priv
115  integer:: iostat
116  namelist /dispatcher6_params/ verbose, max_stalled, retry_stalled, do_delay
117  !-----------------------------------------------------------------------------
118  ! An optional namelist can be used to turn debugging on
119  !-----------------------------------------------------------------------------
120  call trace%begin('dispatcher6_t%init')
121  call mpi_mesg%init
122  rewind(io%input)
123  read(io%input, dispatcher6_params, iostat=iostat)
124  write (io%output, dispatcher6_params)
125  call trace_end
126 END SUBROUTINE init
127 
128 !===============================================================================
129 !> Execute the task list, updating it until it is empty.
130 !===============================================================================
131 SUBROUTINE execute (self, task_list, test)
132  class(dispatcher6_t):: self
133  type(task_list_t), pointer:: task_list
134  logical:: test
135  !.............................................................................
136  real(8):: sec
137  integer:: dims(4)
138  integer, save:: itimer=0
139  !-----------------------------------------------------------------------------
140  call trace%begin ('dispatcher6_t%execute', itimer=itimer)
141  call startup (task_list)
142  call tic (time=sec)
143  call timer%print
144  !-----------------------------------------------------------------------------
145  ! Loop over tasks
146  !-----------------------------------------------------------------------------
147  !$omp parallel
148  do while (task_list%na > 0 .and. wallclock() < io%job_seconds)
149  call update_list (task_list, test)
150  if (io%do_stop) call mpi%abort ('stop flag')
151  if (task_list%na == task_list%n_tasks) then
152  !$omp atomic
153  min_nq = min(min_nq,task_list%nq)
154  end if
155  end do
156  write (io_unit%log,*) 'thread',omp%thread,' arrived'
157  flush (io_unit%log)
158  !$omp barrier
159  !$omp end parallel
160  call timer%print
161  call mpi_mesg%diagnostics(1)
162  call toc ('wall time', timer%n_update, time=sec)
163  call mpi%barrier ('end')
164  write (io%output,*) "task list finished, min_nq =", min_nq
165  call trace%end (itimer)
166 END SUBROUTINE execute
167 
168 !===============================================================================
169 !> Update the state of the task list, taking the steps necessary to update the
170 !> head task on the ready_queue, and check for consequences. Two strategies:
171 !>
172 !> 1) The threads pick up tasks from the queue themselves, and put itself or
173 !> other tasks back onto the queue, based on the results of list_t%check_ready
174 !>
175 !> In this case the threads are prevented from messing up for each other by
176 !> using critical regions when manipulating the queue, and by using status bits
177 !> to indicate the state each task is in. These can be 1) in the queue, and
178 !> ready to be updated, 2) not in the queue, and busy, 3) not in the queue, and
179 !> not busy. The 'ready' bit is set while the task is in the queue, and the
180 !> 'busy' but is set while the task is busy being updated. A task should be
181 !> checked for being ready only when in state 3, meaning only when none of the
182 !> two bits are set.
183 !>
184 !> 2) The master thread takes care of picking tasks from the queue, starting an
185 !> OMP thread to update it, and checking for nbors that are ready to be
186 !> updated as a consquence
187 !===============================================================================
188 SUBROUTINE update_list (task_list, test)
189  type(task_list_t), pointer:: task_list
190  logical:: test
191  !.............................................................................
192  class(link_t), pointer:: head, prev
193  class(task_t), pointer:: task, otask
194  class(mesg_t), pointer:: mesg
195  logical:: already_busy, was_refined
196  real(8):: wc
197  real(8), save:: time, otime=0d0
198  integer, save:: oid=0
199  integer:: id, nq
200  integer, save:: itimer=0
201  !.............................................................................
202  call trace%begin('dispatcher6::update_list', itimer=itimer)
203  !-----------------------------------------------------------------------------
204  ! Check the sent_list for completed sends
205  !-----------------------------------------------------------------------------
206  if (mpi%size > 1) then
207  !$omp atomic read
208  nq = task_list%nq
209  call mpi_mesg%sent_list%check_sent (nq)
210  end if
211  call mpi_io%iwrite_list%check ! I/O check
212  !-----------------------------------------------------------------------------
213  ! Pick a task off the queue, in a very brief critical region
214  !-----------------------------------------------------------------------------
215  call task_list%lock%set()
216  head => task_list%queue ! queue start
217  if (associated(head)) then
218  task_list%queue => head%next_time ! chop head off
219  end if
220  call task_list%lock%unset()
221  if (associated(head)) then
222  task => head%task
223  task%atime = task%time
224  call task%lock%set()
225  id = task%id
226  if (task%state==1) then ! verify ready state
227  call set_state (task, 2) ! set busy state
228  !$omp atomic
229  task_list%nq = task_list%nq-1 ! decrement queue count
230  task%nq = task_list%nq ! for info print
231  call task%lock%unset()
232  if (task%is_set(bits%virtual)) then
233  call unpack (task_list, task%mesg, head)
234  else
235  call update_task (task_list, head, test, was_refined)
236  end if
237  if (.not. was_refined) then
238  call check_nbors (task_list, head) ! any nbors ready?
239  end if
240  call task%lock%set()
241  call set_state (task, 0) ! mark done
242  else
243  write (io%output,*) 'WARNING: queue head task was in state', task%state
244  end if
245  call task%lock%unset
246  !-----------------------------------------------------------------------------
247  ! If the queue is empty, check all tasks; this may be due to late packages
248  !-----------------------------------------------------------------------------
249  else
250  call check_all (task_list)
251  end if
252  call trace_end (itimer)
253 END SUBROUTINE update_list
254 
255 !===============================================================================
256 !> Update the task
257 !===============================================================================
258 SUBROUTINE update_task (task_list, head, test, was_refined)
259  class(task_list_t):: task_list
260  class(link_t), pointer:: head
261  logical:: test
262  logical, optional:: was_refined
263  !.............................................................................
264  class(task_t), pointer:: task
265  real(8):: wc
266  logical:: refined, derefined
267  integer, save:: itimer=0
268  !----------------------------------------------------------------------------
269  call trace%begin('dispatcher6::update_task', itimer=itimer)
270  task => head%task
271  !-----------------------------------------------------------------------------
272  ! Check if refinement is needed on the task; if so this will push new tasks
273  ! onto the queue, with the same task time; i.e., to the head of the queue.
274  ! If the task is virtual, it will not be checked by this rank.
275  !-----------------------------------------------------------------------------
276  call refine%check_current(task_list, head, refined, derefined)
277  if (derefined) then
278  call trace%end (itimer)
279  return
280  end if
281  if (present(was_refined)) then
282  was_refined = refined
283  end if
284  !-----------------------------------------------------------------------------
285  ! Download nbor info -- this may be an experiment_t procedure, but if not,
286  ! the call should be answered by a solver-specific procedure (which may or
287  ! may not choose to call the generic patch guard zone handler in tasks/)
288  !-----------------------------------------------------------------------------
289  call task%dnload ! download nbor info
290  !-----------------------------------------------------------------------------
291  ! Update the task, whatever that means (may include call to task%output)
292  !-----------------------------------------------------------------------------
293  task%rotated = .false.
294  call task%update ! update the task
295  if (.not.task%rotated) then
296  call rotate (task)
297  end if
298  call task%info (task_list%nq, task_list%na) ! print info on stdout
299  !-----------------------------------------------------------------------------
300  ! If the task is a boundary patch, first check if it should be given to
301  ! another rank. A patch that has been given to another rank becomes
302  ! a virtual patch, and the load balance procedure has already sent those
303  ! of its nbors that became new boundary patches over to relevant ranks,
304  ! while the patch ittask_list is sent here, with bits%virtual+swap_reqest set.
305  !-----------------------------------------------------------------------------
306  if (task%is_set(bits%boundary)) then ! boundary patch?
307  head%task%nq = task_list%nq ! make sure to pass on
308  if (load_balance%check_load (head)) then ! sell?
309  !$omp atomic
310  task_list%na = task_list%na-1
311  !$omp atomic
312  task_list%nb = task_list%nb-1
313  !$omp atomic
314  task_list%nv = task_list%nv-1
315  call task_list%count_status ! redundant? (FIXME)
316  end if
317  if (task%id == io%id_debug) &
318  write(io_unit%mpi,*) &
319  'DBG task_list_t%update: calling send_to_vnbors', task%id
320  call task_list%send_to_vnbors (head) ! send to virtual nbors
321  end if
322  !-----------------------------------------------------------------------------
323  ! Tasks that have finished are subtracted from the task list count but are
324  ! not removed, since their data may be needed by other tasks (including on
325  ! other ranks). They are, however, not added back onto the ready queue.
326  !-----------------------------------------------------------------------------
327  call task%lock%set()
328  if (task%has_finished()) then ! finished:
329  call set_state (task, 4)
330  call task%lock%unset()
331  call load_balance%active (.false.) ! turn off load balancing
332  !$omp atomic
333  task_list%na = task_list%na-1
334  else
335  call task%lock%unset()
336  end if
337  call trace%end (itimer)
338 END SUBROUTINE update_task
339 
340 !===============================================================================
341 !> Among a task and its neighbor tasks, move local tasks to ready_queue if they
342 !> are ready.
343 !>
344 !> The link pointer and everything it points to are private to this task, and
345 !> are not at this point in time accessible from the ready queue.
346 !===============================================================================
347 SUBROUTINE check_nbors (task_list, link)
348  class(list_t):: task_list
349  class(link_t), pointer:: link
350  class(link_t), pointer:: nbor
351  class(task_t), pointer:: task
352  integer, save:: itimer=0
353  !.............................................................................
354  call trace_begin('dispatcher6::check_nbors', itimer=itimer)
355  task => link%task ! main task
356  nbor => link%nbor ! first nbor
357  do while (associated (nbor)) ! keep going until end
358  !print *, nbor%task%id, nbor%task%lock%id, nbor%task%lock%thread, omp_get_thred_num()
359  call check_ready (task_list, nbor%link) ! pointer back
360  nbor => nbor%next ! next nbor
361  end do
362  if (link%task%state==0) &
363  call check_ready (task_list, link) ! finally check link task
364  call trace_end (itimer)
365 END SUBROUTINE check_nbors
366 
367 !===============================================================================
368 !> Check if the link task is ready, and if so, add it to the ready_queue
369 !===============================================================================
370 SUBROUTINE check_ready (task_list, link)
371  class(list_t):: task_list
372  class(link_t), pointer:: link
373  class(task_t), pointer:: task
374  class(link_t), pointer:: nbor
375  logical:: ok
376  integer:: state
377  integer, save:: itimer=0
378  !-----------------------------------------------------------------------------
379  call trace%begin ('dispatcher6::check_ready', itimer=itimer)
380  task => link%task
381  call task%lock%set()
382  state = task%state
383  call task%lock%unset()
384  !-----------------------------------------------------------------------------
385  ! Only check tasks that are not in the queue, busy, frozen, or external
386  !-----------------------------------------------------------------------------
387  if (task%state==0) then
388  if (task%is_set(bits%virtual)) then
389  !$omp critical (irecv_cr)
390  ok = task%mesg%is_complete()
391  if (ok) then
392  if (task%mesg%req==0) then
393  call task%mesg%irecv (task%rank, task%id)
394  end if
395  end if
396  !$omp end critical (irecv_cr)
397  else
398  ok = .true.
399  nbor => link%nbor ! start on nbor list
400  do while (associated (nbor)) ! keep going until end
401  if (nbor%needed) then
402  if (.not. is_ahead_of(nbor%task, task)) then ! fail?
403  ok = .false.
404  exit
405  end if
406  end if
407  nbor => nbor%next ! next nbor
408  end do
409  end if
410  if (ok) then
411  call task%lock%set()
412  call set_state (task, 1) ! go to state 1
413  call queue_by_time (task_list, link) ! add task to queue
414  call task%lock%unset()
415  end if
416  end if
417  call trace%end (itimer)
418 END SUBROUTINE check_ready
419 
420 !===============================================================================
421 !===============================================================================
422 SUBROUTINE queue_by_time (task_list, this)
423  class(list_t):: task_list
424  class(link_t), pointer:: this
425  class(link_t), pointer:: next, prev
426  class(task_t), pointer:: task
427  integer, save:: itimer=0
428  integer:: nit
429  !-----------------------------------------------------------------------------
430  call trace_begin ('dispatcher6::queue_by_time ', itimer=itimer)
431  call task_list%lock%set
432  task => this%task
433  mpi_mesg%n_ready = mpi_mesg%n_ready+1
434  nullify (prev)
435  next => task_list%queue
436  do while (associated(next))
437  if (associated(next%task, task)) then
438  write (io_unit%log,*) omp_mythread, ' WARNING: task', task%id, ' is already in ready queue'
439  go to 9
440  else if (next%task%time > task%time) then
441  this%next_time => next
442  if (associated(prev)) then
443  prev%next_time => this
444  else
445  task_list%queue => this
446  end if
447  !$omp atomic
448  task_list%nq = task_list%nq+1
449  go to 9
450  end if
451  prev => next
452  next => next%next_time
453  end do
454  task_list%nq = task_list%nq+1
455  if (associated(prev)) then
456  prev%next_time => this
457  else
458  task_list%queue => this
459  end if
460  nullify (this%next_time)
461 9 continue
462  call task_list%lock%unset
463  call trace_end (itimer)
464 END SUBROUTINE queue_by_time
465 
466 !===============================================================================
467 !> Check if source (which is a nbor task) is ahead of target (which is the one to
468 !> possibly move to the ready queue), using source%dtime*target%grace as the grace
469 !> period, since we want to limit the extrapolation in the nbor task to at most
470 !> target%grace*source%dtime.
471 !===============================================================================
472 LOGICAL FUNCTION is_ahead_of (source, target)
473  class(task_t):: source, target
474  !.............................................................................
475  real(8):: nbtime, nbdtime, tgtime
476  integer:: state, istep
477  !-----------------------------------------------------------------------------
478  call source%lock%set()
479  nbtime = source%time
480  nbdtime = source%dtime
481  state = source%state
482  istep = source%istep
483  call source%lock%unset()
484  !-----------------------------------------------------------------------------
485  call target%lock%set()
486  tgtime = target%time
487  call target%lock%unset()
488  !-----------------------------------------------------------------------------
489  ! -- if a task is frozen (in time) assume it is forever ahead of other tasks
490  if (state==4) then
491  is_ahead_of = .true.
492  ! -- do not use a grace interval for different levels or for the first steps
493  else if (source%level /= target%level .or. istep < 3) then
494  is_ahead_of = nbtime >= tgtime
495  ! -- use a grace interval that is fraction of the nbor time step
496  else
497  is_ahead_of = nbtime + nbdtime*target%grace > tgtime
498  end if
499  if (io_unit%verbose>1) then
500  if (target%id==io%id_debug.or.io_unit%verbose>4) &
501  print'(i6,i4,2x,a,i6,3f9.5,l3)', source%id, omp_mythread, 'mk is_ahead_of: ', &
502  target%id, nbtime, nbdtime*target%grace, tgtime, is_ahead_of
503  end if
504 END FUNCTION is_ahead_of
505 
506 !===============================================================================
507 !> Unpack a message, where the MPI tag is the task id. Use that to search
508 !> for the task, apply its unpack method, and check if any nbors become ready.
509 !> This entire operation should be threadsafe, since no other thread should be
510 !> working on the same message and the same patch.
511 !===============================================================================
512 SUBROUTINE unpack (self, mesg, link)
513  class(task_mesg_t):: self
514  class(mesg_t), pointer:: mesg
515  class(link_t), pointer:: link
516  class(link_t), pointer:: link2
517  class(task_t), pointer:: task
518  logical:: failed
519  integer:: id
520  integer, save:: itimer=0
521  !-----------------------------------------------------------------------------
522  call trace%begin ('dispatcher6::unpack', itimer=itimer)
523  if (mesg%nbuf < 40) then
524  call load_balance%unpack (mesg%buffer)
525  return
526  end if
527  !$omp critical (unpack_cr)
528  task => link%task
529  failed = .false.
530  !-----------------------------------------------------------------------------
531  ! Guard against lingering extra messages to a swapped patch
532  !-----------------------------------------------------------------------------
533  if (task%is_set (bits%boundary)) then
534  write (io_unit%log,'(f12.6,2x,a,i9,3x,5l1)') wallclock(), &
535  'task_mesg_mod::unpack ERROR, received mpi_mesg for boundary task:', task%id, &
536  task%is_set(bits%internal), &
537  task%is_set(bits%boundary), &
538  task%is_set(bits%virtual), &
539  task%is_set(bits%external), &
540  task%is_set(bits%swap_request)
541  failed = .true.
542  end if
543  if (task%is_set (bits%ready)) then
544  write (io_unit%log,'(f12.6,2x,a,i9,3x,5l1)') wallclock(), &
545  'task_mesg_mod::unpack ERROR, received mpi_mesg for task with ready bit:', &
546  task%id, &
547  task%is_set(bits%internal), &
548  task%is_set(bits%boundary), &
549  task%is_set(bits%virtual), &
550  task%is_set(bits%external), &
551  task%is_set(bits%swap_request)
552  failed = .true.
553  end if
554  !---------------------------------------------------------------------------
555  ! Unpack a patch message (which includes swapping the roles of boundary bits).
556  ! Since an already existing patch may, at any one time, be under investigation
557  ! by check_nbors, it must be protected by a critical region (or an OMP
558  ! lock) while it is being updated here
559  !---------------------------------------------------------------------------
560  id = task%id
561  call task%unpack (mesg)
562  if (mpi_mesg%debug) &
563  write (io_unit%log,'(f12.6,2x,a,i9,1p,e18.6)') wallclock(), &
564  'unpk: id, time =', task%id, task%time
565  if (id /= mesg%id) then
566  write(io%output,'(i6,i4,2x,a,3i6)') mpi%rank, omp%thread, &
567  'unpack ERROR: wrong mesg%id', id, task%id, mesg%id
568  write(io_unit%log,'(f12.6,i6,i4,2x,a,4i6)') wallclock(), mpi%rank, &
569  omp%thread, 'unpack ERROR: wrong mesg%id', mesg%sender, id, task%id, mesg%id
570  end if
571  if (.not. failed) then
572  !$omp atomic
573  mpi_mesg%n_unpk = mpi_mesg%n_unpk+1
574  !$omp end atomic
575  !---------------------------------------------------------------------------
576  ! If the boundary+swap bits are set, this is a task that has just changed
577  ! rank, and it needs to have its nbor relations re-initialized. This includes
578  ! resorting (removing + re-adding) the nbor's nbor lists in rank order.
579  ! FIXME: The load balancing steps should be checked for threadsafe operation
580  !---------------------------------------------------------------------------
581  if (task%is_set(bits%swap_request) .and. task%is_set(bits%boundary)) then
582  self%na = self%na+1; self%nb = self%nb+1; self%nv = self%nv-1
583  call self%init_nbors (link)
584  call task%clear (bits%swap_request+bits%ready)
585  call self%update_nbor_status (link)
586  call self%count_status
587  if (verbose>1) &
588  write(io%output,'(f12.6,2x,a,i6,a,i9,a,i6)') &
589  wallclock(),'LB: rank',mpi%rank,' given patch',task%id,' by',mesg%sender
590  if (verbose>0) &
591  write (io_unit%log,*) 'task_mesg_t%unpack: swapped virtual to boundary:', task%id
592  !---------------------------------------------------------------------------
593  ! If the link has no nbors it is a newly created virtual task. Does it need
594  ! an nbor list? At least we can use the nbor list to check that the link is
595  ! in its nbors nbor lists. A new virtual task (where no task existed) means
596  ! that some nbor of it has changed from internal to boundary, which will be
597  ! checked by the test_nbor_status call below, but only if an nbor list exists.
598  !---------------------------------------------------------------------------
599  !else if (.not.associated(link%nbor)) then
600  else if (task%is_set(bits%swap_request) .and. task%is_set(bits%virtual)) then
601  if (verbose>0) &
602  write (io_unit%log,*) 'task_mesg_t%unpack: new virtual patch:', task%id
603  self%nv = self%nv+1
604  call self%init_nbors (link)
605  call task%clear (bits%swap_request+bits%ready)
606  call self%update_nbor_status (link)
607  call self%count_status
608  end if
609  end if
610  !$omp end critical (unpack_cr)
611  call trace%end (itimer)
612 END SUBROUTINE unpack
613 
614 !===============================================================================
615 !> Start-up preparation; initialize task message, look for updateable tasks
616 !===============================================================================
617 SUBROUTINE startup (task_list)
618  class(task_list_t):: task_list
619  class(link_t), pointer:: link
620  class(task_t), pointer:: task
621  !-----------------------------------------------------------------------------
622  call trace%begin ('dispatcher6::startup')
623  call task_list%info
624  !-----------------------------------------------------------------------------
625  ! Initialize the task message, and request the first package
626  !-----------------------------------------------------------------------------
627  link => task_list%head
628  do while (associated(link))
629  task => link%task
630  if (task%is_set (bits%virtual)) then
631  call task%allocate_mesg
632  task%wc_last = wallclock()
633  call task%mesg%irecv (task%rank, task%id)
634  end if
635  link => link%next
636  end do
637  !-----------------------------------------------------------------------------
638  ! Look for tasks ready to update
639  !-----------------------------------------------------------------------------
640  link => task_list%head
641  do while (associated(link))
642  call set_state (task, 0)
643  call check_ready (task_list, link)
644  link => link%next
645  end do
646  call timer%print
647  task_list%n_tasks = task_list%na
648  !-----------------------------------------------------------------------------
649  ! This may not be needed, but might avoid initial load balance excursions
650  !-----------------------------------------------------------------------------
651  call mpi%barrier ('task_list%execute')
652  call trace%end()
653 END SUBROUTINE startup
654 
655 !===============================================================================
656 !> Among a task and its neighbor tasks, move local tasks to ready_queue if they
657 !> are ready, and send task data to non-locals.
658 !===============================================================================
659 SUBROUTINE check_all (list)
660  class(list_t):: list
661  class(link_t), pointer:: link
662  integer, save:: itimer=0
663  !.............................................................................
664  call trace_begin('dispatcher6::check_all', itimer=itimer)
665  call list%lock%set
666  link => list%head
667  do while (associated (link)) ! keep going until end
668  call check_ready (list, link) ! link ready?
669  link => link%next
670  end do
671  call list%lock%unset
672  call trace_end (itimer)
673 END SUBROUTINE check_all
674 
675 !===============================================================================
676 !> Rotate time slots. The initial conditions are in slot 1, and the first time
677 !> step puts new values in the 'new' slot 2, while saving the time step used in
678 !> dt(1). Then the current slot (it) becomes 2, and the new one becomes 3, etc.
679 !> This way, there is no need to copy memory btw time steps.
680 !===============================================================================
681 SUBROUTINE rotate (self)
682  class(task_t):: self
683  integer:: i
684  integer, save:: itimer=0
685  !.............................................................................
686  if (self%rotated) return
687  call trace_begin ('dispatcher6::rotate',itimer=itimer)
688  call self%lock%set()
689  !-----------------------------------------------------------------------------
690  self%dt(self%it) = self%dtime ! just updated
691  ! ZEUS determines a new time step at the end of its update; this is to
692  ! prevent the clobbering of the updated time step; FIXME!
693  if (trim(self%kind) /= 'zeus_mhd_patch') then
694  self%dt(self%new)= self%dtime ! next estimate
695  end if
696  self%time = self%time + self%dtime ! time update
697  self%t(self%new) = self%time ! initial time
698  self%it = self%new ! update time slot, new
699  self%new = mod(self%new,self%nt)+1 ! increment / rotate
700  do i=1,self%nt-1
701  self%iit(i) = self%iit(i+1)
702  end do
703  self%iit(self%nt) = self%new ! new right-most slot
704  self%istep = self%istep + 1
705  self%rotated = .true.
706  !$omp flush
707  call self%lock%unset()
708  call trace_end (itimer)
709 END SUBROUTINE rotate
710 
711 !===============================================================================
712 !> Set a new task state, while keeping track of the number of tasks in each state
713 !===============================================================================
714 SUBROUTINE set_state (task, in)
715  class(task_t), pointer:: task
716  integer:: in, ip
717  !.............................................................................
718  ip = task%state
719  task%state = in
720  n_state(ip) = n_state(ip) - 1
721  n_state(in) = n_state(in) + 1
722  d_state(in) = d_state(in) + 1
723  if (verbose>1) &
724  print '(a,i4,f12.6,2x,5i4,2x,2i3)', ' dispatcher6:', omp%thread, wallclock(), n_state, ip, in
725 END SUBROUTINE set_state
726 
727 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
Dispatcher method that relies on all threads maintaining a "ready queue", with tasks ready for updati...
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