38 real:: cadence, patch_cost
40 real(8):: time, wall, dtime
41 real(8):: otime, owall
42 type(rank_info_t),
pointer:: next => null()
43 class(
mesg_t),
pointer:: mesg
47 procedure:: measure_load
49 integer,
save:: n_io_rank_info = (4*4 + 6*8)/4
57 real(8):: time, wall, dtime
58 real(8):: otime, owall
60 type:: rank_info_list_t
61 type(rank_info_t),
pointer:: head => null()
62 type(rank_info_t),
pointer:: tail => null()
72 type(rank_info_t):: rank_info
73 type(rank_info_list_t):: rank_info_list
75 logical,
save:: only_initial=.false.
76 real,
save:: cadence=1., threshold=10., grace=0.3, duration=0.0
77 real,
save:: next_info
78 integer,
save:: excess=0
79 real:: q_min=10., q_max=40.
83 type(random_t):: random
91 procedure:: check_load
92 procedure:: print => print_lb
95 type(mesg_list_t):: nbor_sent_list
100 SUBROUTINE init (self)
102 logical,
save:: on=.false.
104 type(io_rank_info_t):: io_rank_info
106 namelist /load_balance_params/ on, cadence, threshold, grace, &
107 duration, only_initial, q_min, q_max
110 call self%lock%init (
'load')
112 read(io%input, load_balance_params, iostat=iostat)
113 write (io%output, load_balance_params)
117 if (n_io_rank_info*4 /= storage_size(io_rank_info)/8)
then 118 print *, n_io_rank_info*4, storage_size(io_rank_info)/8
119 error stop
'The hardwired loadbalance_mod::n_io_rank_info is incorrect' 121 n_io_rank_info = storage_size(io_rank_info)/32
127 SUBROUTINE active (self, flag)
132 END SUBROUTINE active
137 SUBROUTINE pack (self, info, mesg)
139 type(rank_info_t):: info
140 class(mesg_t),
pointer:: mesg
141 type(io_rank_info_t):: io_rank_info
144 call trace%begin (
'rank_info%pack')
147 allocate (mesg%buffer(n))
148 allocate (mesg%reqs(rank_info_list%n))
151 io_rank_info%ok = info%ok
152 io_rank_info%rank = info%rank
153 io_rank_info%cost = info%cost
154 io_rank_info%nq = info%nq
155 io_rank_info%n_swap= info%n_swap
156 io_rank_info%time = info%time
157 io_rank_info%otime = info%otime
158 io_rank_info%dtime = info%dtime
159 io_rank_info%wall = info%wall
160 io_rank_info%owall = info%owall
161 call anonymous_copy (n, io_rank_info, mesg%buffer)
162 if (io%verbose>0)
then 163 write (io_unit%log,
'(a,i6,1p,g12.3,2i6,g16.6)')
'rank_info_mod::pack rank,cost,nq,n,time =', &
164 info%rank, info%cost, info%nq, n, info%time
167 write (io_unit%log,*)
'send buffer =', mesg%buffer(1:5)
174 SUBROUTINE unpack (self, buffer)
176 integer,
dimension(:),
pointer:: buffer
177 class(rank_info_t),
pointer:: nbor_info
178 type(io_rank_info_t):: io_rank_info
182 call trace%begin (
'rank_info%unpack')
184 write (io_unit%log,*)
'recv buffer =', buffer(1:5)
185 call anonymous_copy (n, buffer, io_rank_info)
186 if (io%verbose>1)
then 187 write (io_unit%log,*)
'load_balance%unpack: rank', io_rank_info%rank
190 if (io_rank_info%rank==mpi%rank)
return 194 nbor_info => rank_info_list%head
195 do while (
associated(nbor_info))
196 if (nbor_info%rank == io_rank_info%rank)
exit 197 nbor_info => nbor_info%next
202 if (
associated(nbor_info))
then 203 write (io_unit%log,*)
'unpack: old', io_rank_info%rank
205 write (io_unit%log,*)
'unpack: new', io_rank_info%rank
207 call rank_info_list%append (nbor_info)
212 nbor_info%ok = io_rank_info%ok
213 nbor_info%rank = io_rank_info%rank
214 nbor_info%cost = io_rank_info%cost
215 nbor_info%nq = io_rank_info%nq
216 nbor_info%n_swap= io_rank_info%n_swap
217 nbor_info%time = io_rank_info%time
218 nbor_info%otime = io_rank_info%otime
219 nbor_info%dtime = io_rank_info%dtime
220 nbor_info%wall = io_rank_info%wall
221 nbor_info%owall = io_rank_info%owall
222 wc = wallclock()-io_rank_info%wall
223 if (io%verbose>1)
then 224 write (io_unit%log,
'(a,i6,1p,g12.3,i6,2g16.6)')
'rank_info%unpack: rank,load,nq,time,latency =', &
225 io_rank_info%rank, io_rank_info%cost, io_rank_info%nq, io_rank_info%time, wc
228 END SUBROUTINE unpack
233 SUBROUTINE add (self, rank)
235 class(rank_info_t),
pointer:: nbor_info
236 type(mesg_t),
pointer:: mesg
240 if (rank==mpi%rank)
then 241 print *,mpi%rank,
'WARNING: trying to add same rank to nbor_info' 245 call nbor_info%lock%set
246 nbor_info => rank_info_list%head
247 do while (
associated(nbor_info))
248 if (nbor_info%rank == rank)
then 252 nbor_info => nbor_info%next
260 if (io%verbose>2)
then 261 write (io_unit%log,*)
'rank_info%add: already on list', rank
265 nbor_info%rank = rank
267 nbor_info%mesg => mesg
268 mesg%nbuf = n_io_rank_info
269 allocate (mesg%buffer(mesg%nbuf))
270 call mesg%recv (rank, mesg%tag)
271 call rank_info_list%append (nbor_info)
272 if (io%verbose>1)
then 273 write (io_unit%log,*)
'rank_info%add', rank, rank_info_list%n
276 call nbor_info%lock%unset
282 SUBROUTINE append (self, rank_info)
283 class(rank_info_list_t):: self
284 class(rank_info_t),
pointer:: rank_info
286 call trace%begin (
'rank_info%append')
287 if (
associated(self%head))
then 288 self%tail%next => rank_info
290 self%head => rank_info
292 self%tail => rank_info
295 END SUBROUTINE append
300 SUBROUTINE remove (self, this)
301 class(rank_info_list_t):: self
302 class(rank_info_t),
pointer:: this, rank_info, prev
304 call trace%begin (
'rank_info%remove')
307 rank_info => self%head
308 do while (
associated(rank_info))
309 if (
associated(rank_info,this))
then 313 if (
associated(prev))
then 314 prev%next => this%next
319 self%head => this%next
324 if (
associated(this,self%tail))
then 331 rank_info => rank_info%next
339 END SUBROUTINE remove
346 SUBROUTINE send (self)
347 class(rank_info_list_t):: self
348 class(rank_info_t),
pointer:: nbor_info
349 class(mesg_t),
pointer:: mesg
351 if (.not.
associated(self%head))
return 352 call trace%begin(
'rank_info%send')
357 mesg%nbuf = n_io_rank_info
358 allocate (mesg%buffer(mesg%nbuf))
359 write (io_unit%log,*)
'mk3',rank_info%rank
360 call load_balance%pack (rank_info, mesg)
361 write (io_unit%log,*)
'mk4',rank_info%rank
362 write (io_unit%log,*)
'mesg%buffer =', mesg%buffer(1:5)
364 nbor_info => self%head
365 do while (
associated(nbor_info))
366 if (io%verbose>1)
then 367 write (io_unit%log,
'(f12.6,2x,a,2i5,1p,e12.3)') &
368 wallclock(),
'rank_info%send', nbor_info%rank, &
369 rank_info%rank, rank_info%cost
372 call mesg%send (nbor_info%rank, mesg%tag)
373 nbor_info => nbor_info%next
375 call nbor_sent_list%add (mesg)
376 call nbor_sent_list%remove_completed
384 SUBROUTINE recv (self)
385 class(rank_info_list_t):: self
386 class(rank_info_t),
pointer:: nbor_info
387 class(mesg_t),
pointer:: mesg
389 if (.not.
associated(self%head))
return 390 call trace%begin(
'rank_info%recv')
395 nbor_info => self%head
396 do while (
associated(nbor_info))
397 mesg => nbor_info%mesg
398 if (mesg%completed())
then 399 if (io%verbose>1)
then 400 write(io_unit%log,*)
'rank_info_list%recv: from', nbor_info%rank
403 call load_balance%unpack (mesg%buffer)
404 call mesg%recv (nbor_info%rank, tag=mesg%tag)
406 nbor_info => nbor_info%next
421 FUNCTION imbalance (self, nbor)
RESULT (diff)
422 class(rank_info_t):: self
423 class(rank_info_t),
pointer:: nbor
424 real(8):: p, time, diff
434 diff = 2.0*(q_min/(q_min+nbor%nq)-q_max/(q_max+self%nq))
435 END FUNCTION imbalance
441 SUBROUTINE measure_load (self, head)
442 class(rank_info_t):: self
443 class(link_t),
pointer:: head
444 class(link_t),
pointer:: link
445 class(task_t),
pointer:: task
446 real:: load, sum, sum_cost, cells, sum_cells, ready
447 real(8):: dt, sum_dt, wc
448 integer,
save:: itimer=0
451 call trace%begin (
'rank_info%measure_load', itimer=itimer)
455 do while (
associated(link))
456 ok = merge(.false., ok, link%task%rank==mpi%rank .and. link%task%dtime==0d0)
461 rank_info%dtime = 1.0
462 call trace_end (itimer)
470 do while (
associated(link))
474 if (task%rank==mpi%rank)
then 475 cells = product(task%mesh%n)
476 sum_cells = sum_cells + cells
477 sum_cost = sum_cost + cells/task%dtime
485 rank_info%cost = sum_cost
486 rank_info%rank = mpi%rank
487 write (io_unit%log,*)
'mk0', rank_info%rank, mpi%rank
488 rank_info%dtime = sum_cells/sum_cost
490 if (wc > rank_info%wall)
then 491 rank_info%owall = rank_info%wall
493 rank_info%otime = rank_info%time
494 rank_info%time = 0.9*rank_info%time &
497 if (io%verbose > 1) &
498 write (io_unit%log,
'(a,i5,1p,3e12.3)')
'measure_load: nq,load,cost,dt =', &
499 rank_info%nq, rank_info%cost, rank_info%dtime
500 call trace%end (itimer)
501 END SUBROUTINE measure_load
506 FUNCTION find (self, rank, debug)
RESULT (nbor_info)
507 class(rank_info_list_t):: self
509 logical,
optional:: debug
510 class(rank_info_t),
pointer:: nbor_info
512 call trace%begin(
'rank_info_list%find')
513 nbor_info => self%head
514 if (
present(debug))
then 515 write (io_unit%log,*)
'debug: associated =',
associated(nbor_info)
516 do while (
associated(nbor_info))
517 write (io_unit%log,*)
'debug: rank =', nbor_info%rank
518 if (nbor_info%rank == rank)
then 521 nbor_info => nbor_info%next
525 do while (
associated(nbor_info))
526 if (nbor_info%rank == rank)
then 529 nbor_info => nbor_info%next
538 SUBROUTINE print_lb (self, time)
541 class(rank_info_t),
pointer:: nbor_info
542 real:: load_diff, imbalance
544 if (.not.rank_info%ok)
return 546 nbor_info => rank_info_list%head
547 do while (
associated(nbor_info))
548 load_diff = (rank_info%cost-nbor_info%cost)/rank_info%patch_cost
550 imbalance = rank_info%imbalance (nbor_info)
551 write (io_unit%log,
'(2f12.6,2x,a,i6,1p,4g12.3,3i6)') &
554 'rank_info_list: rnk,load,time,cost[12],wall,nq =', &
555 nbor_info%rank,load_diff,imbalance, &
556 nbor_info%cost, rank_info%cost, &
557 nbor_info%nq, rank_info%nq, nbor_info%n_swap
558 nbor_info => nbor_info%next
561 END SUBROUTINE print_lb
576 FUNCTION check_load (self, head)
RESULT (sell)
578 class(link_t),
pointer:: head, nbor
580 class(task_t),
pointer:: task
581 class(patch_t),
pointer:: patch
582 class(rank_info_t),
pointer:: nbor_info
583 integer,
save:: delay=0
584 logical:: load_condition, time_condition
586 real:: load_diff, cost, imbalance, randomu
587 logical,
save:: make_estimate=.true.
588 integer,
save:: itimer=0
594 if (.not.self%on)
return 595 call trace%begin (
'load_balance%check_load', itimer=itimer)
598 patch => task2patch(head%task)
599 rank_info%nq = head%task%nq
604 if (wc > next_info)
then 605 next_info = next_info + cadence
606 rank_info%cadence = cadence
607 rank_info%rank = mpi%rank
608 rank_info%patch_cost = product(patch%mesh%gn)/patch%dtime
609 call rank_info%measure_load (head)
610 call rank_info_list%send
611 call rank_info_list%recv
612 call load_balance%print (head%task%time)
618 if (rank_info%ok .and. wc<duration)
then 624 do while (
associated(nbor))
626 write (io_unit%log,
'(a,2i9,3i6,2f12.6,l3)')
'LB: ids,nqs,rank,times', &
627 head%task%id, nbor%task%id, rank_info%nq, nbor%task%nq, nbor%task%rank, &
628 nbor%task%time, head%task%time, nbor%task%is_set(bits%virtual)
629 if (nbor%task%is_set (bits%virtual))
then 630 nbor_info => rank_info_list%find (nbor%task%rank)
631 if (nbor%task%rank == mpi%rank)
then 632 write (io_unit%log,*) &
633 'rank_info_mod::check_load virtual bit on my rank', nbor%task%id
635 else if (
associated(nbor_info))
then 636 imbalance = rank_info%imbalance (nbor_info)/grace
637 imbalance = max(imbalance, -1.)
645 randomu = self%random%ran1()
647 write (io_unit%log,
'("LB:",2i4,2x,2l1,2f6.2,l4)') &
648 mpi%rank,nbor%task%rank,rank_info%ok,nbor_info%ok,imbalance, &
649 randomu,randomu < 0.05*(1.-exp(-imbalance))
650 if (rank_info%ok.and.nbor_info%ok .and. &
651 imbalance > 0.0 .and. &
652 randomu < 0.05*(1.-exp(-imbalance)))
then 653 if (io%verbose>0)
then 655 wc,
'LB: rank',mpi%rank,
' gives patch',head%task%id,
' to',nbor%task%rank, &
656 excess, nbor_info%n_swap, &
657 nbor_info%cost, rank_info%cost
658 1
format(f12.6,2x,a,i6,a,i9,a,i6,2i5,1p,2g12.3)
659 write (io_unit%log,2) &
660 wc,
'load_balance: giving patch',head%task%id,
' to',nbor%task%rank, &
661 excess, nbor_info%n_swap, &
662 nbor_info%cost, rank_info%cost
663 2
format(f12.6,2x,a,i9,a,i6,2i5,1p,2g12.3)
666 call list%give_to (head, nbor%task%rank)
669 write (io_unit%log,*)
'swapped boundary to virtual:', head%task%id
673 write (io_unit%log,*) &
674 'check_load ERROR: nbor_info not associated, rank', nbor%task%rank
675 nbor_info => rank_info_list%find (nbor%task%rank, debug=.true.)
678 else if (nbor%task%is_set (bits%external))
then 679 write (io_unit%log,*) nbor%task%id,
'LB: external status on nbor from rank', nbor%task%rank
680 else if (nbor%task%rank /= mpi%rank)
then 681 write (io_unit%log,*) nbor%task%id,
'LB: inconsistent status on nbor from rank', nbor%task%rank
687 call trace%end(itimer)
688 END FUNCTION check_load
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.
Keep track of neighbor ranks and their loads, by sending and receiving short messages, storing the info in a linked list.
The lock module uses nested locks, to allow versatile use of locks, where a procedure may want to mak...
Template module for tasks.