DISPATCH
dispatcher1_mod.f90
1 MODULE dispatcher1_mod
2  USE io_mod
3  USE io_unit_mod
4  USE trace_mod
5  USE omp_mod
6  USE omp_timer_mod
7  USE mpi_mod
8  USE timer_mod
9  USE link_mod
10  USE mpi_mesg_mod
11  USE task_list_mod
12  USE bits_mod
13  USE process_mod
14  USE global_mod
15  USE index_mod
16  implicit none
17  private
18  type, public:: dispatcher1_t
19  integer:: verbose=0
20  integer:: n_spawn=0
21  type(task_list_t), pointer:: task_list => null()
22  type(process_t):: process
23  contains
24  procedure:: execute
25  end type
26  type(dispatcher1_t), public:: dispatcher1
27  type(global_t):: average_density
28 CONTAINS
29 
30 !===============================================================================
31 !===============================================================================
32 SUBROUTINE init (self, task_list)
33  class(dispatcher1_t):: self
34  type(task_list_t), pointer:: task_list
35  !.............................................................................
36 END SUBROUTINE init
37 
38 !===============================================================================
39 !> Simple dispatcher, which in each loop through the task list takes on the
40 !> first task that is ready, and then spawns other threads that handle the
41 !> remaining tasks that are ready.
42 !===============================================================================
43 SUBROUTINE execute (self, task_list, test)
44  class(dispatcher1_t):: self
45  type(task_list_t), pointer:: task_list
46  logical:: test
47  !.............................................................................
48  class(link_t), pointer:: link, nbor
49  logical:: ready, mytask
50  real(8):: start, v, t
51  integer, save:: itimer=0
52  !-----------------------------------------------------------------------------
53  self%task_list => task_list
54  call tic (time=start)
55  !call self%process%update (task_list)
56  !call average_density%init ('density', mpi%size, 5, cadence=0.01)
57  call timer%print()
58  !$omp parallel private(link,nbor,ready,mytask) default(shared)
59  !$omp master
60  mytask = .false.
61  task_list%nq = 0
62  do while (task_list%na>0 .and. wallclock()-start < io%job_seconds)
63  call trace%begin ('dispatcher1_t%execute', itimer=itimer)
64  if (self%verbose>2) write (io_unit%dispatcher,*) wallclock(), 'check_mpi'
65  call task_list%check_mpi()
66  call self%process%update (task_list)
67  !v = task_list%average (idx%d, t)
68  !print *, 'AVER', mpi%rank, v, t
69  !average_density%order = min (3, task_list%head%task%istep)
70  !call average_density%update (v, 1d0, t)
71  link => task_list%head
72  do while (associated(link))
73  ready = .false.
74  if (link%task%state>2) then
75  if (self%verbose>3) write (io_unit%dispatcher,*) wallclock(), link%task%id, 'busy'
76  else if (link%task%is_set (bits%internal) .or. link%task%is_set (bits%boundary)) then
77  ready = .true.
78  nbor => link%nbor
79  do while (associated(nbor))
80  if (io%verbose > 2) &
81  print *, 'dispatcher1: task, nbor, is_ahead =', link%task%id, nbor%task%id, nbor%task%is_ahead_of (link%task)
82  ready = ready .and. nbor%task%is_ahead_of (link%task)
83  if (.not.ready) then
84  if (self%verbose>2) write (io_unit%dispatcher,*) wallclock(), link%task%id, 'failed', nbor%task%id, nbor%task%time, link%task%time
85  exit
86  end if
87  nbor => nbor%next
88  end do
89  if (io%verbose > 2) &
90  print *, 'dispatcher1: task, ready =', link%task%id, ready
91  !-----------------------------------------------------------------------
92  ! If a task is ready, change its state to 2, so we can keep track of nq
93  !-----------------------------------------------------------------------
94  if (ready) then
95  mpi_mesg%n_ready = mpi_mesg%n_ready+1
96  if (link%task%state<2) then
97  !$omp atomic write
98  link%task%state = 2
99  !$omp atomic
100  task_list%nq = task_list%nq+1
101  end if
102  !---------------------------------------------------------------------
103  ! The master thread takes on at least one task update per loop
104  !---------------------------------------------------------------------
105  if (mytask) then
106  if (self%verbose>2) write (io_unit%dispatcher,*) wallclock(), link%task%id, 'my task'
107  call task_list%check_mpi()
108  if (self%verbose>2) write (io_unit%dispatcher,*) wallclock(), link%task%id, 'check task_list'
109  if (self%verbose>1) write (io_unit%log,*) wallclock(), link%task%id, 'update start'
110  if (io%verbose > 1) &
111  print *, omp%thread, 'dispatche1: updating task', link%task%id
112  call task_list%update (link, test)
113  !$omp atomic
114  task_list%nq = task_list%nq-1
115  !$omp atomic write
116  link%task%state = 1
117  if (self%verbose>1) write (io_unit%log,*) wallclock(), link%task%id, 'update end'
118  mytask = .false.
119  !---------------------------------------------------------------------
120  ! If multi-threaded, spawn background tasks up to OMP_NUM_THREADS + 1
121  !---------------------------------------------------------------------
122  else if (omp%nthreads>2) then
123  if (self%n_spawn <= omp%nthreads+1) then
124  if (self%verbose>1) write (io_unit%dispatcher,*) wallclock(), link%task%id, 'spawning'
125  if (self%verbose>2) write (io_unit%log,*) wallclock(), link%task%id, 'spawn begin'
126  !$omp atomic write
127  link%task%state = 3
128  !$omp atomic
129  self%n_spawn = self%n_spawn + 1
130  if (io%verbose > 2) &
131  print *, omp%thread, 'dispatche1: spawning task', link%task%id
132  !$omp task default(shared) firstprivate(link)
133  call self%task_list%check_mpi ()
134  if (self%verbose>2) write (io_unit%log,*) wallclock(), link%task%id, 'check task_list'
135  if (self%verbose>1) write (io_unit%log,*) wallclock(), link%task%id, 'update start', self%n_spawn
136  if (io%verbose > 1) &
137  print *, omp%thread, 'dispatche1: updating task', link%task%id
138  call task_list%update (link, test)
139  !$omp atomic write
140  link%task%state = 1
141  !$omp atomic
142  self%n_spawn = self%n_spawn - 1
143  if (self%verbose>1) write (io_unit%log,*) wallclock(), link%task%id, 'update end', self%n_spawn
144  !$omp end task
145  !$omp atomic
146  task_list%nq = task_list%nq-1
147  if (self%verbose>2) write (io_unit%log,*) wallclock(), link%task%id, 'spawn end', self%n_spawn
148  else
149  if (self%verbose>2) write (io_unit%log,*) wallclock(), link%task%id, 'taskyield'
150  !$omp taskyield
151  end if
152  !---------------------------------------------------------------------
153  ! Single-threaded: just update
154  !---------------------------------------------------------------------
155  else
156  if (self%verbose>2) write (io_unit%dispatcher,*) wallclock(), link%task%id, 'updating'
157  if (self%verbose>2) write (io_unit%log,*) wallclock(), link%task%id, 'update start'
158  call task_list%update (link, test)
159  link%task%state = 1
160  task_list%nq = task_list%nq-1
161  if (self%verbose>2) write (io_unit%log,*) wallclock(), link%task%id, 'update end'
162  end if
163  end if
164  end if
165  link => link%next
166  end do
167  if (self%verbose>0) call flush(io_unit%dispatcher)
168  mytask = .true.
169  call trace%end (itimer)
170  end do
171  !$omp end master
172  !$omp end parallel
173  call timer%print()
174  call mpi_mesg%diagnostics(1)
175  call toc ('wall time', timer%n_update, time=start)
176 END SUBROUTINE execute
177 
178 END MODULE dispatcher1_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
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
Data type to keep and maintain information on MPI processes.
Task list data type, with methods for startup and updates. Message handling is inherited from the tas...
This index file has slot indices for all solver, all initially equal to zero It is the responsibility...
Definition: index_mod.f90:7
Definition: io_mod.f90:4