DISPATCH
dispatcher3_mod.f90
1 !===============================================================================
2 !> Execute a task list. Since only the master thread is calling check_mpi(), we
3 !> need to make sure that it handles all send/recv, hence send_priv=.false. and
4 !> recv_priv=.false., and we can use the simplest receive mechanism (recv_active
5 !> =.true.), with no buffering needed (queue_unpack=.false.). These values are
6 !> imposed after the input namelists are read, to make sure the choices are
7 !> correct.
8 !>
9 !> Strategy: Keep track of, separately, the number of ready tasks, the number
10 !> of currently spawned tasks, and the number of currently busy tasks. To this
11 !> end, define the following states:
12 !>
13 !> state=0: task is inactive or new
14 !> state=1: the task is ready to update, but not yet spawned
15 !> state=2: the task has been spawned
16 !> state=3: the task is busy updating
17 !> state=4: the task has finished updating
18 !>
19 !> The simplest strategy for counting is to keep track of the number of tasks
20 !> in each state, by incrementing the count for the new state and decrementing
21 !> the count for the old state, whenever the state changes. These counts should
22 !> be part of the dispatcher data type.
23 !===============================================================================
25  USE io_mod
26  USE io_unit_mod
27  USE trace_mod
28  USE omp_mod
29  USE omp_timer_mod
30  USE mpi_mod
31  USE mpi_io_mod
32  USE timer_mod
33  USE link_mod
34  USE mpi_mesg_mod
35  USE task_list_mod
36  USE bits_mod
37  USE global_mod
38  USE task_mod
39  implicit none
40  private
41  type, public:: dispatcher3_t
42  integer:: verbose=0
43  integer:: n_spawn=0
44  !type(task_list_t), pointer:: task_list => null()
45  contains
46  procedure:: init
47  procedure:: execute
48  end type
49  integer:: n_fail=0
50  integer:: n_state(0:4)=0
51  integer:: d_state(0:4)=0
52  integer:: verbose=0
53  integer:: n_write=2000
54  integer(8):: n_check=0, n_ready=0
55  real(8):: wc_failed=0d0
56  real(8):: start
57  logical:: use_critical=.false.
58  type(dispatcher3_t), public:: dispatcher3
59 CONTAINS
60 
61 !===============================================================================
62 !===============================================================================
63 SUBROUTINE init (self, task_list)
64  class(dispatcher3_t):: self
65  type(task_list_t), pointer:: task_list
66  integer:: iostat
67  namelist /dispatcher3_params/ verbose, use_critical, n_write
68  !.............................................................................
69  rewind(io%input)
70  read (io%input, dispatcher3_params, iostat=iostat)
71  write (io%output, dispatcher3_params)
72 END SUBROUTINE init
73 
74 !===============================================================================
75 !> Simple dispatcher, which spawns other threads that handle tasks that are
76 !> ready. If / when the master thread has spawned a number of tasks that depend
77 !> on the implementation, it will participate in execution of the tasks.
78 !===============================================================================
79 SUBROUTINE execute (self, task_list, test)
80  class(dispatcher3_t):: self
81  type(task_list_t), pointer:: task_list
82  logical:: test, fell_through
83  !.............................................................................
84  class(link_t), pointer:: link, nbor
85  class(task_t), pointer:: task
86  logical:: mytask
87  integer:: n1, n2
88  real(8):: start_fail, start_iter
89  integer, save:: itimer=0
90  !-----------------------------------------------------------------------------
91  call trace%begin ('dispatcher3_t%execute', itimer=itimer)
92  call io%header('begin dispatcher3_t%execute: Any opportunity dispatcher')
93  call self%init (task_list)
94  n_state = 0; n_state(0) = io%ntask
95  call tic (time=start)
96  call timer%print()
97  !$omp parallel private(link,nbor,task,mytask) shared(n_state) default(shared)
98  !$omp master
99  do while (task_list%na>0 .and. wallclock()-start < io%job_seconds)
100  start_iter = wallclock()
101  !---------------------------------------------------------------------------
102  ! Check if there is MPI work
103  !---------------------------------------------------------------------------
104  call task_list%check_mpi()
105  !---------------------------------------------------------------------------
106  ! Run through the task list, looking for tasks that are ready
107  !---------------------------------------------------------------------------
108  fell_through = .true.
109  link => task_list%head
110  do while (associated(link))
111  task => link%task
112  if (task%is_clear (bits%virtual)) then
113  !-----------------------------------------------------------------------
114  ! If task is updated, set it to idle; this should ONLY be done by the
115  ! master thread
116  !-----------------------------------------------------------------------
117  if (link%task%state==4) then
118  call set_state (link%task, 0)
119  end if
120  !-----------------------------------------------------------------------
121  ! If task is idle, check if it is ready to update
122  !-----------------------------------------------------------------------
123  if (task%state==0) then
124  if (is_ready(link)) &
125  call set_state (link%task, 1)
126  end if
127  !-----------------------------------------------------------------------
128  ! If task is ready to update, spawn a background task
129  !-----------------------------------------------------------------------
130  if (task%state==1) then
131  fell_through = .false.
132  !$omp atomic read
133  task_list%nq = n_state(1)
134  !$omp atomic
135  task_list%nq = task_list%nq + n_state(2)
136  call set_state (link%task, 2)
137  !$omp task firstprivate(task_list,link,test) default(shared)
138  call set_state (link%task, 3)
139  call task_list%update (link, test)
140  call set_state (link%task, 4)
141  !$omp end task
142  end if
143  end if
144  link => link%next
145  end do
146  !---------------------------------------------------------------------------
147  ! Start a thread doing I/O, if buffers from all tasks pending
148  !---------------------------------------------------------------------------
149  if (mpi_io%iwrite_list%n == io%nwrite) then
150  !$omp task default(shared)
151  call mpi_io%iwrite_list%check()
152  !$omp end task
153  end if
154  call write_state (io_unit%queue, '1')
155  if (verbose>1) call print_state ('1')
156  !---------------------------------------------------------------------------
157  ! Diagnostics
158  !---------------------------------------------------------------------------
159  if (fell_through) then
160  if (verbose>3) print *,'dispatcher3: fell through'
161  wc_failed = wc_failed + (wallclock()-start_fail - start_iter)
162  n_fail = n_fail+1
163  else
164  if (n_fail>0 .and. verbose>0) &
165  call print_state ('2')
166  n_fail = 0
167  end if
168  end do
169  !$omp end master
170  !$omp end parallel
171  call timer%print()
172  if (omp%master) &
173  write(io%output,'(a,i6,4(a,f7.4))') &
174  ' dispatcher3_t%finalize: rank =',mpi%rank, &
175  ', fraction of ready tasks =', real(n_ready)/real(n_check), &
176  ', fraction of dispatcher idle time =', wc_failed/max(1d-10,wallclock()-start)
177  call mpi_mesg%diagnostics(1)
178  call toc ('wall time', timer%n_update, time=start)
179  call trace%end (itimer)
180 END SUBROUTINE execute
181 
182 !===============================================================================
183 !===============================================================================
184 SUBROUTINE print_state (label)
185  character(len=*):: label
186  !-----------------------------------------------------------------------------
187  call write_state (io_unit%output, label)
188 END SUBROUTINE
189 
190 !===============================================================================
191 !===============================================================================
192 SUBROUTINE write_state (unit, label)
193  integer:: unit
194  character(len=*):: label
195  !-----------------------------------------------------------------------------
196  if (n_write <= 0) return
197  !$omp critical (set_state_cr)
198  n_write = n_write-1
199  write(unit,'("DISPATCHER3: ",a,f12.6,f9.3,2x,3(2x,a,i6),9(2x,a,i5))') &
200  label, wallclock(), &
201  wc_failed/max(1d-10,wallclock()-start), &
202  'fail:',n_fail , &
203  'idl:', n_state(0), &
204  'rdy:', n_state(1), &
205  'spw:', n_state(2), &
206  'act:', n_state(3), &
207  'upd:', n_state(4), &
208  'idl:', d_state(0), &
209  'rdy:', d_state(1), &
210  'spw:', d_state(2), &
211  'act:', d_state(3), &
212  'upd:', d_state(4)
213  d_state = 0
214  !$omp end critical (set_state_cr)
215 END SUBROUTINE write_state
216 
217 !===============================================================================
218 !> Set a new task state, while keeping track of the number of tasks in each state
219 !===============================================================================
220 SUBROUTINE set_state (task, in)
221  class(task_t), pointer:: task
222  integer:: in, ip
223  !...........................................................................
224  if (use_critical) then
225  !$omp critical (set_state_cr)
226  ip = task%state
227  task%state = in
228  n_state(ip) = n_state(ip) - 1
229  n_state(in) = n_state(in) + 1
230  d_state(in) = d_state(in) + 1
231  if (verbose>1) &
232  print '(a,i4,f12.6,2x,5i4,2x,2i3)', ' dispatcher3:', omp%thread, wallclock(), n_state, ip, in
233  !$omp end critical (set_state_cr)
234  else
235  !$omp atomic read
236  ip = task%state
237  !$omp atomic
238  n_state(ip) = n_state(ip) - 1
239  !$omp atomic
240  n_state(in) = n_state(in) + 1
241  !$omp atomic
242  d_state(in) = d_state(in) + 1
243  !$omp atomic write
244  task%state = in
245  if (verbose>1) &
246  write (io%output,'(a,i4,f12.6,2x,5i4,2x,2i3)') &
247  ' dispatcher3:', omp%thread, wallclock(), n_state, ip, in
248  end if
249 END SUBROUTINE set_state
250 
251 !===============================================================================
252 !> Check if a task is ready to update, by changing if all nbor task are "ahead
253 !> of" the task in question
254 !===============================================================================
255 LOGICAL FUNCTION is_ready (link)
256  class(link_t), pointer:: link, nbor
257  integer:: state
258  !...........................................................................
259  !$omp atomic
260  n_check = n_check+1
261  call io%assert (associated(link), 'is_ready: link missing')
262  call io%assert (associated(link%task), 'is_ready: link%task missing')
263  !$omp atomic read
264  state = link%task%state
265  if (link%task%is_set (bits%virtual)) then
266  is_ready = .false.
267  else
268  is_ready = .true.
269  nbor => link%nbor
270  do while (associated(nbor))
271  if (nbor%needed) then
272  !$omp atomic read
273  state = nbor%task%state
274  if (state==3) then
275  is_ready = .false.
276  else
277  is_ready = is_ready .and. nbor%task%is_ahead_of (link%task)
278  end if
279  if (.not.is_ready) then
280  if (verbose > 2) &
281  print *, link%task%id, 'is_ready: failed on', nbor%task%id, &
282  nbor%task%time, link%task%time
283  exit
284  end if
285  end if
286  nbor => nbor%next
287  end do
288  end if
289  if (is_ready) then
290  !$omp atomic
291  n_ready = n_ready+1
292  end if
293 END FUNCTION is_ready
294 
295 END MODULE dispatcher3_mod
Each thread uses a private timer data type, with arrays for start time and total time for each regist...
Definition: timer_mod.f90:11
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...
Data type for computing global average, while using only nearest node nbor communication.
Definition: global_mod.f90:5
Execute a task list. Since only the master thread is calling check_mpi(), we need to make sure that i...
Task list data type, with methods for startup and updates. Message handling is inherited from the tas...
Definition: io_mod.f90:4
Template module for tasks.
Definition: task_mod.f90:4