Octopus
multicomm.F90
Go to the documentation of this file.
1!! Copyright (C) 2002-2015 M. Marques, A. Castro, A. Rubio, G. Bertsch, X. Andrade
2!!
3!! This program is free software; you can redistribute it and/or modify
4!! it under the terms of the GNU General Public License as published by
5!! the Free Software Foundation; either version 2, or (at your option)
6!! any later version.
7!!
8!! This program is distributed in the hope that it will be useful,
9!! but WITHOUT ANY WARRANTY; without even the implied warranty of
10!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11!! GNU General Public License for more details.
12!!
13!! You should have received a copy of the GNU General Public License
14!! along with this program; if not, write to the Free Software
15!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16!! 02110-1301, USA.
17!!
18
19#include "global.h"
20
51
52module multicomm_oct_m
53 use blacs_oct_m
55 use debug_oct_m
56 use global_oct_m
57 use, intrinsic :: iso_fortran_env
59 use mpi_oct_m
62#if defined(HAVE_OPENMP)
63 use omp_lib
64#endif
65 use parser_oct_m
67 use utils_oct_m
68
69 implicit none
70
71 private
72
73 public :: &
76#if defined(HAVE_MPI)
77 multicomm_create_all_pairs, &
78#endif
87
88 integer, public, parameter :: &
89 P_MASTER = 1, &
90 p_slave = 2
91
92 integer, public, parameter :: &
93 PAR_AUTO = -1, &
94 par_no = 0
95
96 integer, parameter :: n_par_types = 4
97 character(len=11), parameter :: par_types(0:n_par_types) = &
98 (/ &
99 "serial ", &
100 "ParDomains", &
101 "ParStates ", &
102 "ParKPoints", &
103 "ParOther " &
104 /)
105
106 integer, parameter :: MAX_INDEX = 5
107
113 type multicomm_t
114 private
115 integer :: n_node
116
117 integer, public :: par_strategy
118
119 integer, allocatable :: group_sizes(:)
120 integer, allocatable, public :: who_am_i(:)
121 type(MPI_Comm), allocatable, public :: group_comm(:)
122 type(MPI_Comm), public :: dom_st_comm = mpi_comm_undefined
123 type(MPI_Comm), public :: st_kpt_comm = mpi_comm_undefined
124 type(MPI_Comm), public :: dom_st_kpt_comm = mpi_comm_undefined
125 type(mpi_grp_t), public :: intranode_grp
126 type(mpi_grp_t), public :: internode_grp
127
128 integer :: nthreads
129 integer :: node_type
130 logical :: have_slaves
131
132 type(MPI_Comm) :: full_comm = mpi_comm_undefined
133 integer :: full_comm_rank
134 type(MPI_Comm), public :: master_comm = mpi_comm_undefined
135 integer :: master_comm_rank
136 type(MPI_Comm), public :: slave_intercomm = mpi_comm_undefined
137
138 logical :: reorder_ranks
139 end type multicomm_t
140
143 private
144 type(mpi_grp_t) :: grp
145 integer :: rounds
146 integer, allocatable, public :: schedule(:, :)
148
149contains
150
151 ! ---------------------------------------------------------
152 subroutine multicomm_all_pairs_copy(apout, apin)
153 type(multicomm_all_pairs_t), intent(inout) :: apout
154 type(multicomm_all_pairs_t), intent(in) :: apin
155
157
158 call mpi_grp_copy(apout%grp, apin%grp)
159 apout%rounds = apin%rounds
160 if (allocated(apin%schedule)) then
161 safe_allocate(apout%schedule(1:size(apin%schedule, 1), 1:size(apin%schedule, 2)))
162 apout%schedule = apin%schedule
163 end if
164
166 end subroutine multicomm_all_pairs_copy
167
168 ! ---------------------------------------------------------
170 subroutine multicomm_init(mc, namespace, base_grp, mode_para, n_node, index_range, min_range)
171 type(multicomm_t), intent(out) :: mc
172 type(namespace_t), intent(in) :: namespace
173 type(mpi_grp_t), intent(in) :: base_grp
174 type(calc_mode_par_t), intent(in) :: mode_para
175 integer, intent(in) :: n_node
176 integer(int64), intent(inout) :: index_range(:)
177 integer, intent(in) :: min_range(:)
178
179 integer :: ii, num_slaves, slave_level, ipar
180 integer :: parse(1:P_STRATEGY_MAX), default(1:P_STRATEGY_MAX)
181 integer :: parallel_mask, default_mask
182
184
185 mc%n_node = n_node
186 parallel_mask = mode_para%parallel_mask()
187 default_mask = mode_para%default_parallel_mask()
188
189 call messages_print_with_emphasis(msg="Parallelization", namespace=namespace)
190
191 !%Variable ReorderRanks
192 !%Default no
193 !%Type logical
194 !%Section Execution::Parallelization
195 !%Description
196 !% This variable controls whether the ranks are reorganized to have a more
197 !% compact distribution with respect to domain parallelization which needs
198 !% to communicate most often. Depending on the system, this can improve
199 !% communication speeds.
200 !%End
201 call parse_variable(namespace, 'ReorderRanks', .false., mc%reorder_ranks)
202
203 call messages_obsolete_variable(namespace, 'ParallelizationStrategy')
204 call messages_obsolete_variable(namespace, 'ParallelizationGroupRanks')
205
206 do ipar = 1, p_strategy_max
207 default(ipar) = par_no
208 if (bitand(default_mask, ibset(0, ipar - 1)) /= 0) then
209 default(ipar) = par_auto
210 end if
211 end do
213 !%Variable ParDomains
214 !%Type integer
215 !%Default auto
216 !%Section Execution::Parallelization
217 !%Description
218 !% This variable controls the number of processors used for the
219 !% parallelization in domains.
220 !% The special value <tt>auto</tt>, the default, lets Octopus
221 !% decide how many processors will be assigned for this
222 !% strategy. To disable parallelization in domains, you can use
223 !% <tt>ParDomains = no</tt> (or set the number of processors to
224 !% 1).
225 !%
226 !% The total number of processors required is the multiplication
227 !% of the processors assigned to each parallelization strategy.
228 !%Option auto -1
229 !% The number of processors is assigned automatically.
230 !%Option no 0
231 !% This parallelization strategy is not used.
232 !%End
233 call parse_variable(namespace, 'ParDomains', default(p_strategy_domains), parse(p_strategy_domains))
234
235 !%Variable ParStates
236 !%Type integer
237 !%Section Execution::Parallelization
238 !%Description
239 !% This variable controls the number of processors used for the
240 !% parallelization in states. The special value <tt>auto</tt> lets
241 !% Octopus decide how many processors will be assigned for this
242 !% strategy. To disable parallelization in states, you can use
243 !% <tt>ParStates = no</tt> (or set the number of processors to 1).
244 !%
245 !% The default value depends on the <tt>CalculationMode</tt>. For
246 !% <tt>CalculationMode = td</tt> the default is <tt>auto</tt>, while
247 !% for for other modes the default is <tt>no</tt>.
248 !%
249 !% The total number of processors required is the multiplication
250 !% of the processors assigned to each parallelization strategy.
251 !%Option auto -1
252 !% The number of processors is assigned automatically.
253 !%Option no 0
254 !% This parallelization strategy is not used.
255 !%End
256 call parse_variable(namespace, 'ParStates', default(p_strategy_states), parse(p_strategy_states))
257
258 !%Variable ParKPoints
259 !%Type integer
260 !%Default auto
261 !%Section Execution::Parallelization
262 !%Description
263 !% This variable controls the number of processors used for the
264 !% parallelization in K-Points and/or spin.
265 !% The special value <tt>auto</tt> lets Octopus decide how many processors will be
266 !% assigned for this strategy. To disable parallelization in
267 !% KPoints, you can use <tt>ParKPoints = no</tt> (or set the
268 !% number of processors to 1).
269 !%
270 !% The total number of processors required is the multiplication
271 !% of the processors assigned to each parallelization strategy.
272 !%Option auto -1
273 !% The number of processors is assigned automatically.
274 !%Option no 0
275 !% This parallelization strategy is not used.
276 !%End
277 call parse_variable(namespace, 'ParKPoints', default(p_strategy_kpoints), parse(p_strategy_kpoints))
278
279 !%Variable ParOther
280 !%Type integer
281 !%Default auto
282 !%Section Execution::Parallelization
283 !%Description
284 !% This variable controls the number of processors used for the
285 !% 'other' parallelization mode, that is CalculatioMode
286 !% dependent. For <tt>CalculationMode = casida</tt>, it means
287 !% parallelization in electron-hole pairs.
288 !%
289 !% The special value <tt>auto</tt>,
290 !% the default, lets Octopus decide how many processors will be
291 !% assigned for this strategy. To disable parallelization in
292 !% Other, you can use <tt>ParOther = no</tt> (or set the
293 !% number of processors to 1).
294 !%
295 !% The total number of processors required is the multiplication
296 !% of the processors assigned to each parallelization strategy.
297 !%Option auto -1
298 !% The number of processors is assigned automatically.
299 !%Option no 0
300 !% This parallelization strategy is not used.
301 !%End
302 call parse_variable(namespace, 'ParOther', default(p_strategy_other), parse(p_strategy_other))
303
304 do ipar = 1, p_strategy_max
305 if (parse(ipar) == par_no) parse(ipar) = 1
306 end do
307
308 call strategy()
309
310 mc%have_slaves = .false.
311
312 if (mc%par_strategy /= p_strategy_serial) then
313 safe_allocate(mc%group_sizes(1:p_strategy_max))
314
315 mc%group_sizes = 1
316
317 do ipar = 1, p_strategy_max
318 if (multicomm_strategy_is_parallel(mc, ipar)) then
319 mc%group_sizes(ipar) = parse(ipar)
320 else if (parse(ipar) /= 1) then
321 call messages_write('Ignoring specification for ' // par_types(ipar))
322 call messages_new_line()
323 call messages_write('This parallelization strategy is not available.')
324 call messages_warning()
325 end if
326 end do
327
328 call assign_nodes()
329
330
331 !%Variable ParallelizationNumberSlaves
332 !%Type integer
333 !%Default 0
334 !%Section Execution::Parallelization
335 !%Description
336 !% Slaves are nodes used for task parallelization. The number of
337 !% such nodes is given by this variable multiplied by the number
338 !% of domains used in domain parallelization.
339 !%End
340 call parse_variable(namespace, 'ParallelizationNumberSlaves', 0, num_slaves)
341
342 ! the slaves must be defined at a certain parallelization level, for the moment this is state parallelization.
343 slave_level = p_strategy_states
344 mc%have_slaves = (num_slaves > 0)
345
346 if (mc%have_slaves) then
347 call messages_experimental('Task parallelization')
348 end if
349
350 ! clear parallel strategies that were available but will not be used
351 do ii = 1, p_strategy_max
352 if (mc%group_sizes(ii) == 1) mc%par_strategy = ibclr(mc%par_strategy, ii - 1)
353 end do
354
355 ! reset
356 call sanity_check()
357 end if
358
359 call group_comm_create()
360
361 call messages_print_with_emphasis(namespace=namespace)
362
363 pop_sub(multicomm_init)
364
365 contains
366
367 ! ---------------------------------------------------------
368 subroutine strategy()
369 integer :: jj, ipar
370
371 push_sub(multicomm_init.strategy)
372
373 if (base_grp%size > 1) then
374
375 mc%par_strategy = 0
376
377 do ipar = 1, p_strategy_max
378 if (parse(ipar) == par_auto .or. parse(ipar) > 1) then
379 mc%par_strategy = ibset(mc%par_strategy, ipar - 1)
380 end if
381 end do
382
383 if (mc%par_strategy /= bitand(mc%par_strategy, parallel_mask)) then
384 call messages_write('Parallelization strategies unavailable for this run mode are being discarded.')
385 call messages_warning()
386 end if
387
388 mc%par_strategy = bitand(mc%par_strategy, parallel_mask)
389
390 if (mc%par_strategy == p_strategy_serial) then
391 message(1) = "More than one node is available, but this run mode cannot run with the requested parallelization."
392 message(2) = "Please select a parallelization strategy compatible with"
393 jj = 2
394 do ii = 1, n_par_types
395 if (bitand(parallel_mask, 2**(ii - 1)) /= 0) then
396 jj = jj + 1
397 write(message(jj), '(2a)') " -> ", par_types(ii)
398 end if
399 end do
400 jj=jj+1
401 write(message(jj),'(a,i6)') "mc%par_strategy is : ",mc%par_strategy
402 call messages_fatal(jj, only_root_writes = .true.)
403 end if
404 else
405 mc%par_strategy = p_strategy_serial
406 end if
407
408 mc%nthreads = 1
409#if defined(HAVE_OPENMP)
410 !$omp parallel
411 !$omp master
412 mc%nthreads = omp_get_num_threads()
413 !$omp end master
414 !$omp end parallel
415#endif
416
417 if (mc%par_strategy == p_strategy_serial .and. mc%nthreads == 1) then
418 message(1) = "Info: Octopus will run in *serial*"
419 call messages_info(1, namespace=namespace)
420 else
421 write(message(1),'(a)') 'Info: Octopus will run in *parallel*'
422 write(message(2),'(a)') ''
423 write(message(3),'(a, i8)') ' Number of processes :', base_grp%size
424 write(message(4),'(a, i8)') ' Number of threads per process :', mc%nthreads
425 write(message(5),'(a)') ''
426 call messages_info(5, namespace=namespace)
427 end if
428
429 pop_sub(multicomm_init.strategy)
430 end subroutine strategy
431
432 ! ---------------------------------------------------------
433
434 subroutine assign_nodes()
435 integer :: ii, nn, kk, n_divisors, divisors(1:50)
436 integer(int64) :: n_group_max(1:p_strategy_max)
437
439
440 ! this is the maximum number of processors in each group
441 n_group_max(1:p_strategy_max) = max(index_range(1:p_strategy_max), 1_int64)
442 do kk = 1, p_strategy_max
443 if (.not. multicomm_strategy_is_parallel(mc, kk)) n_group_max(kk) = 1
444 end do
445
446 call messages_write('Debug info: Allowable group ranks:', new_line = .true.)
447 do kk = 1, p_strategy_max
448 call messages_write(par_types(kk), fmt = '2x,a12,":",1x')
449 call messages_write(n_group_max(kk), new_line = .true.)
450 end do
451 call messages_info(debug_only=.true.)
452
453 nn = mc%n_node
454
455 ! first loop, check the processors assigned by the user
456 do ipar = p_strategy_max, 1, -1
457
458 if (mc%group_sizes(ipar) == par_auto) cycle
459
460 if (mc%group_sizes(ipar) > n_group_max(ipar)) then
461 call messages_write('The number of processors specified for '//par_types(ipar)//'(')
462 call messages_write(mc%group_sizes(ipar))
463 call messages_write(')', new_line = .true.)
464 call messages_write('is larger than the degrees of freedom for that level (')
465 call messages_write(n_group_max(ipar))
466 call messages_write(').')
467 call messages_warning()
468 end if
469
470 if (mod(nn, mc%group_sizes(ipar)) /= 0) then
471 call messages_write('The number of processors specified for '//par_types(ipar)//'(')
472 call messages_write(mc%group_sizes(ipar))
473 call messages_write(')', new_line = .true.)
474 call messages_write('is not a divisor of the number of processors (')
475 call messages_write(mc%n_node)
476 call messages_write(').')
477 call messages_fatal()
478 end if
479
480 nn = nn/mc%group_sizes(ipar)
481
482 end do
483
484 ! second loop, now assign the rest automatically
485 do ipar = p_strategy_max, 1, -1
486
487 if (mc%group_sizes(ipar) /= par_auto) cycle
488
489 n_divisors = ubound(divisors, dim = 1)
490 call get_divisors(nn, n_divisors, divisors)
491
492 mc%group_sizes(ipar) = nn
493 do ii = 2, n_divisors
494 if (divisors(ii) > n_group_max(ipar)) then
495 mc%group_sizes(ipar) = divisors(ii - 1)
496 exit
497 end if
498 end do
499
500 nn = nn/mc%group_sizes(ipar)
501
502 end do
503
505 end subroutine assign_nodes
506
507
508 ! ---------------------------------------------------------
510 subroutine sanity_check()
511 real(real64) :: frac
512 integer :: ii, kk
513 integer(int64) :: jj, n_max
514 integer :: real_group_sizes(1:MAX_INDEX)
515
517
518 if (num_slaves > 0) then
519
520 if (mc%group_sizes(slave_level) < num_slaves + 1) then
521 message(1) = 'Too many nodes assigned to task parallelization.'
523 end if
524
525 write(message(1),'(a,i6)') 'Info: Number of slaves nodes :', &
526 num_slaves*product(mc%group_sizes(1:slave_level - 1))
527 call messages_info(1)
528
529 end if
530
531 ! print out some info
532 ii = 0
533 do kk = p_strategy_max, 1, -1
534 real_group_sizes(kk) = mc%group_sizes(kk)
535 if (.not. multicomm_strategy_is_parallel(mc, kk)) cycle
536 ii = ii + 1
537 if (kk == slave_level) real_group_sizes(kk) = real_group_sizes(kk) - num_slaves
538 write(message(ii),'(3a,i6,a,i12,a)') 'Info: Number of nodes in ', &
539 par_types(kk), ' group:', real_group_sizes(kk), ' (', index_range(kk), ')'
540 end do
541 call messages_info(ii)
542
543 ! do we have the correct number of processors
544 if (product(mc%group_sizes(1:p_strategy_max)) /= base_grp%size) then
545 write(message(1),'(a)') 'Inconsistent number of processors:'
546 write(message(2),'(a,i6)') ' MPI processes = ', base_grp%size
547 write(message(3),'(a,i6)') ' Required processes = ', product(mc%group_sizes(1:p_strategy_max))
548 message(4) = ''
549 message(5) = 'You probably have a problem in the ParDomains, ParStates, ParKPoints or ParOther.'
550 call messages_fatal(5, only_root_writes = .true.)
551 end if
552
553 if (any(real_group_sizes(1:p_strategy_max) > index_range(1:p_strategy_max))) then
554 message(1) = "Could not distribute nodes in parallel job. Most likely you are trying to"
555 message(2) = "use too many nodes for the job."
556 call messages_fatal(2, only_root_writes = .true.)
557 end if
558
559 if (any(index_range(1:p_strategy_max) / real_group_sizes(1:p_strategy_max) < min_range(1:p_strategy_max) .and. &
560 real_group_sizes(1:p_strategy_max) > 1)) then
561 message(1) = "I have fewer elements in a parallel group than recommended."
562 message(2) = "Maybe you should reduce the number of nodes."
563 call messages_warning(2)
564 end if
565
566 ! calculate fraction of idle time
567 frac = m_one
568 do ii = 1, p_strategy_max
569 n_max = ceiling(real(index_range(ii), real64) / real(real_group_sizes(ii)), real64)
570 jj = n_max*real_group_sizes(ii)
571 frac = frac*(m_one - real(jj - index_range(ii), real64) / real(jj, real64) )
572 end do
573
574 write(message(1), '(a,f5.2,a)') "Info: Octopus will waste at least ", &
575 (m_one - frac)*100.0_real64, "% of computer time."
576 if (frac < 0.8_real64) then
577 message(2) = "Usually a number of processors which is a multiple of small primes is best."
578 call messages_warning(2)
579 else
580 call messages_info(1)
581 end if
582
584 end subroutine sanity_check
585
586 ! ---------------------------------------------------------
587 subroutine group_comm_create()
588#if defined(HAVE_MPI)
589 logical :: dim_mask(MAX_INDEX)
590 integer :: i_strategy, irank
591 logical :: reorder, periodic_mask(MAX_INDEX)
592 integer :: coords(MAX_INDEX)
593 type(mpi_comm) :: new_comm
594 integer :: new_comm_size
595 character(len=6) :: node_type
596 type(mpi_grp_t) :: reorder_grp
597 type(mpi_group) :: base_group, reorder_group
598 integer :: ranks(base_grp%size)
599 integer :: ii, jj, kk, ll, nn
600 type(mpi_comm) :: reorder_comm
601#endif
602
604
605 mc%node_type = p_master
606
607 safe_allocate(mc%group_comm(1:p_strategy_max))
608 safe_allocate(mc%who_am_i(1:p_strategy_max))
609
610 mc%group_comm = mpi_comm_undefined
611 mc%who_am_i = 0
612
613#if defined(HAVE_MPI)
614 mc%full_comm = mpi_comm_null
615 mc%slave_intercomm = mpi_comm_null
616 if (mc%par_strategy /= p_strategy_serial) then
617 if (mc%reorder_ranks) then
618 ! first, reorder the ranks
619 ! this is done to get a column-major ordering of the ranks in the
620 ! Cartesian communicator, since they a ordered row-major otherwise
621 call mpi_comm_group(base_grp%comm, base_group)
622 ! now transpose the hypercube => get rank numbers in column-major order
623 nn = 1
624 do ii = 1, mc%group_sizes(1)
625 do jj = 1, mc%group_sizes(2)
626 do kk = 1, mc%group_sizes(3)
627 do ll = 1, mc%group_sizes(4)
628 ranks(nn) = (ll-1)*mc%group_sizes(3)*mc%group_sizes(2)*mc%group_sizes(1) &
629 + (kk-1)*mc%group_sizes(2)*mc%group_sizes(1) &
630 + (jj-1)*mc%group_sizes(1) + ii - 1
631 nn = nn + 1
632 end do
633 end do
634 end do
635 end do
636 call mpi_group_incl(base_group, base_grp%size, ranks, reorder_group)
637 ! now get the reordered communicator
638 call mpi_comm_create(base_grp%comm, reorder_group, reorder_comm)
639 call mpi_grp_init(reorder_grp, reorder_comm)
640 else
641 call mpi_grp_copy(reorder_grp, base_grp)
642 end if
643
644 ! Multilevel parallelization is organized in a hypercube. We
645 ! use an MPI Cartesian topology to generate the communicators
646 ! that correspond to each level.
647
648 ! create the topology
649 periodic_mask = .false.
650 reorder = .true.
651
652 ! The domain and states dimensions have to be periodic (2D torus)
653 ! in order to circulate matrix blocks.
656
657 ! We allow reordering of ranks.
658 call mpi_cart_create(reorder_grp%comm, p_strategy_max, mc%group_sizes, periodic_mask, reorder, mc%full_comm)
659
660 call mpi_comm_rank(mc%full_comm, mc%full_comm_rank)
661
662 ! get the coordinates of the current processor
663 call mpi_cart_coords(mc%full_comm, mc%full_comm_rank, p_strategy_max, coords)
664
665 ! find out what type of node this is
666 if (coords(slave_level) >= mc%group_sizes(slave_level) - num_slaves) then
667 mc%node_type = p_slave
668 end if
669
670 if (mc%node_type == p_master) then
671 mc%group_sizes(slave_level) = mc%group_sizes(slave_level) - num_slaves
672 else
673 mc%group_sizes(slave_level) = num_slaves
674 end if
676 call mpi_comm_split(mc%full_comm, mc%node_type, mc%full_comm_rank, new_comm)
677 assert(new_comm /= mpi_comm_null)
678 call mpi_comm_size(new_comm, new_comm_size)
679
680 reorder = .false.
681 if (product(mc%group_sizes(:)) /= new_comm_size) then
682 write(stderr,*) 'node ', mpi_world%rank, ': mc%group_sizes = ', mc%group_sizes, ' new_comm_size = ', new_comm_size
683 call mpi_world%barrier()
684 assert(product(mc%group_sizes(:)) == new_comm_size)
685 end if
686 call mpi_cart_create(new_comm, p_strategy_max, mc%group_sizes, periodic_mask, reorder, mc%master_comm)
687 assert(mc%master_comm /= mpi_comm_null)
688
689 call mpi_comm_free(new_comm)
690
691 call mpi_comm_rank(mc%master_comm, mc%master_comm_rank)
692
693 ! The "lines" of the Cartesian grid.
694 ! Initialize all the communicators, even if they are not parallelized
695 do i_strategy = 1, p_strategy_max
696 dim_mask = .false.
697 dim_mask(i_strategy) = .true.
698 call mpi_cart_sub(mc%master_comm, dim_mask, mc%group_comm(i_strategy))
699 call mpi_comm_rank(mc%group_comm(i_strategy), mc%who_am_i(i_strategy))
700 end do
701
702 ! The domain-state "planes" of the grid (the ones with periodic dimensions).
703 dim_mask = .false.
704 dim_mask(p_strategy_domains) = .true.
705 dim_mask(p_strategy_states) = .true.
706 call mpi_cart_sub(mc%master_comm, dim_mask, mc%dom_st_comm)
707
708 ! The state-kpoints "planes" of the grid
709 dim_mask = .false.
710 dim_mask(p_strategy_states) = .true.
711 dim_mask(p_strategy_kpoints) = .true.
712 call mpi_cart_sub(mc%master_comm, dim_mask, mc%st_kpt_comm)
713
714 ! The domains-states-kpoints "cubes" of the grid
715 dim_mask = .false.
716 dim_mask(p_strategy_domains) = .true.
717 dim_mask(p_strategy_states) = .true.
719 call mpi_cart_sub(mc%master_comm, dim_mask, mc%dom_st_kpt_comm)
720
721 if (num_slaves > 0) call create_slave_intercommunicators()
722
723 call create_intranode_communicator(base_grp, mc%intranode_grp, mc%internode_grp)
724 else
725 ! we initialize these communicators so we can use them even in serial
726 mc%group_comm = base_grp%comm
727 mc%who_am_i = 0
728 mc%master_comm = base_grp%comm
729 mc%dom_st_comm = base_grp%comm
730 mc%st_kpt_comm = base_grp%comm
731 mc%dom_st_kpt_comm = base_grp%comm
732 call mpi_grp_copy(mc%intranode_grp, base_grp)
733 call mpi_grp_copy(mc%internode_grp, base_grp)
734 end if
735
736 ! This is temporary debugging information.
737 if (debug%info .and. mc%par_strategy /= p_strategy_serial) then
738 write(message(1),'(a)') 'Debug: MPI Task Assignment to MPI Groups'
739 write(message(2),'(5a10)') 'World', 'Domains', 'States', 'K-Points', 'Other'
740 call messages_info(1)
741
742 if (mc%node_type == p_slave) then
743 node_type = "slave"
744 else
745 node_type = "master"
746 end if
747 do irank = 0, mpi_world%size - 1
748 if (mpi_world%rank == irank) then
749 write(message(1),'(5i10,5x,a)') mpi_world%rank, mc%who_am_i(p_strategy_domains), mc%who_am_i(p_strategy_states), &
750 mc%who_am_i(p_strategy_kpoints), mc%who_am_i(p_strategy_other), trim(node_type)
751 call messages_info(1, all_nodes = .true.)
752 end if
753 call mpi_world%barrier()
754 end do
755 end if
756#endif
757
759 end subroutine group_comm_create
760
761 ! -----------------------------------------------------
762#ifdef HAVE_MPI
763 subroutine create_slave_intercommunicators()
764 integer :: remote_leader
765 integer :: tag
766 integer :: coords(max_index)
767
768 push_sub(multicomm_init.create_slave_intercommunicators)
769
770 ! create the intercommunicators to communicate with slaves
771
772 ! get the coordinates of the current processor
773 call mpi_cart_coords(mc%full_comm, mc%full_comm_rank, p_strategy_max, coords)
774
775 !now get the rank of the remote_leader
776 if (mc%node_type == p_slave) then
777 coords(slave_level) = 0
778 else
779 coords(slave_level) = mc%group_sizes(slave_level)
780 end if
781 call mpi_cart_rank(mc%full_comm, coords, remote_leader)
782
783 ! now create the intercommunicator
784 tag = coords(p_strategy_domains)
785 call mpi_intercomm_create(mc%group_comm(slave_level), 0, base_grp%comm, remote_leader, tag, mc%slave_intercomm)
786
787 pop_sub(multicomm_init.create_slave_intercommunicators)
788 end subroutine create_slave_intercommunicators
789#endif
790 end subroutine multicomm_init
791
792
793 ! ---------------------------------------------------------
794 subroutine multicomm_end(mc)
795 type(multicomm_t), intent(inout) :: mc
796
797#if defined(HAVE_MPI)
798 integer :: ii
799#endif
800
801 push_sub(multicomm_end)
802
803 if (mc%par_strategy /= p_strategy_serial) then
804#if defined(HAVE_MPI)
805 ! Delete communicators.
806 do ii = 1, p_strategy_max
807 ! initialized even if not parallelized
808 call mpi_comm_free(mc%group_comm(ii))
809 end do
810 call mpi_comm_free(mc%dom_st_comm)
811 call mpi_comm_free(mc%st_kpt_comm)
812 call mpi_comm_free(mc%dom_st_kpt_comm)
813 call mpi_comm_free(mc%full_comm)
814 call mpi_comm_free(mc%master_comm)
815
816 if (multicomm_have_slaves(mc)) call mpi_comm_free(mc%slave_intercomm)
817
818#endif
819 end if
820
821 safe_deallocate_a(mc%group_sizes)
822 safe_deallocate_a(mc%group_comm)
823 safe_deallocate_a(mc%who_am_i)
824
825 pop_sub(multicomm_end)
826 end subroutine multicomm_end
827
828
829 ! ---------------------------------------------------------
830 logical pure function multicomm_strategy_is_parallel(mc, level) result(rr)
831 type(multicomm_t), intent(in) :: mc
832 integer, intent(in) :: level
833
834 rr = bitand(mc%par_strategy, 2**(level - 1)) /= 0
835
837
838
839 ! ---------------------------------------------------------
846#if defined(HAVE_MPI)
847
848 subroutine multicomm_create_all_pairs(mpi_grp, ap)
849 type(mpi_grp_t), intent(in) :: mpi_grp
850 type(multicomm_all_pairs_t), intent(out) :: ap
851
852 integer :: grp_size, rounds, ir, in
853
854 push_sub(create_all_pairs)
855
856 ap%grp = mpi_grp
857 grp_size = mpi_grp%size
858
859 ! Number of rounds.
860 if (mod(grp_size, 2) == 0) then
861 rounds = grp_size - 1
862 else
863 rounds = grp_size
864 end if
865 ap%rounds = rounds
866
867 ! Calculate schedule.
868 safe_allocate(ap%schedule(0:grp_size - 1, 1:rounds))
869 do ir = 1, rounds
870 do in = 0, grp_size - 1
871 ap%schedule(in, ir) = get_partner(in + 1, ir) - 1
872 end do
873 end do
874
875 pop_sub(create_all_pairs)
876
877 contains
878
879 ! ---------------------------------------------------------
881 integer pure function get_partner(in, ir)
882 integer, intent(in) :: in, ir
883
884 ! No PUSH SUB, called too often.
885
886 if (mod(grp_size, 2) == 0) then
887 get_partner = get_partner_even(grp_size, in - 1, ir - 1) + 1
888 else
889 get_partner = get_partner_odd(grp_size, in - 1, ir - 1) + 1
890 end if
891
892 end function get_partner
893
894 ! ---------------------------------------------------------
895 integer pure function get_partner_even(grp_size, ii, rr) result(pp)
896 integer, intent(in) :: grp_size, ii, rr
897
898 integer :: mm
899
900 ! No PUSH SUB, called too often.
901
902 mm = grp_size / 2
903
904 if (ii == 0) then
905 pp = rr + 1
906 elseif (ii == rr + 1) then
907 pp = 0
908 else
909 ! I never know when to use which remainder function, but here
910 ! it has to be the modulo one. Do not change that!
911 pp = modulo(2 * rr - ii + 1, 2 * mm - 1) + 1
912 end if
913
914 end function get_partner_even
915
916 ! ---------------------------------------------------------
917 integer pure function get_partner_odd(grp_size, ii, rr) result(pp)
918 integer, intent(in) :: grp_size, ii, rr
919
920 integer :: mm
921
922 ! No PUSH SUB, called too often.
923
924 mm = (grp_size + 1) / 2
925
926 pp = get_partner_even(grp_size + 1, ii, rr)
927
928 if (pp == 2 * mm - 1) then
929 pp = ii
930 end if
931
932 end function get_partner_odd
933
934 end subroutine multicomm_create_all_pairs
935#endif
936
940 subroutine multicomm_divide_range(nobjs, nprocs, istart, ifinal, lsize, scalapack_compat)
941 integer, intent(in) :: nobjs
942 integer, intent(in) :: nprocs
943 integer, intent(out) :: istart(:)
944 integer, intent(out) :: ifinal(:)
945 integer, optional, intent(out) :: lsize(:)
946 logical, optional, intent(in) :: scalapack_compat
947
948 integer :: ii, jj, rank
949 logical :: scalapack_compat_
950 integer :: nbl, size
951
952 scalapack_compat_ = optional_default(scalapack_compat, .false.)
953#ifndef HAVE_SCALAPACK
954 scalapack_compat_ = .false.
955#endif
956
957 if (scalapack_compat_) then
958 nbl = nobjs/nprocs
959 if (mod(nobjs, nprocs) /= 0) nbl = nbl + 1
960
961 istart(1) = 1
962 do rank = 1, nprocs
963#ifdef HAVE_SCALAPACK
964 size = numroc(nobjs, nbl, rank - 1, 0, nprocs)
965#endif
966 if (size > 0) then
967 if (rank > 1) istart(rank) = ifinal(rank - 1) + 1
968 ifinal(rank) = istart(rank) + size - 1
969 else
970 istart(rank) = 1
971 ifinal(rank) = 0
972 end if
973 end do
974 else
975
976 if (nprocs <= nobjs) then
977
978 ! procs are assigned to groups by round robin
979 do rank = 0, nprocs - 1
980 jj = nobjs / nprocs
981 ii = nobjs - jj*nprocs
982 if (ii > 0 .and. rank < ii) then
983 jj = jj + 1
984 istart(rank + 1) = rank*jj + 1
985 ifinal(rank + 1) = istart(rank + 1) + jj - 1
986 else
987 ifinal(rank + 1) = nobjs - (nprocs - rank - 1)*jj
988 istart(rank + 1) = ifinal(rank + 1) - jj + 1
989 end if
990 end do
991
992 else
993 do ii = 1, nprocs
994 if (ii <= nobjs) then
995 istart(ii) = ii
996 ifinal(ii) = ii
997 else
998 istart(ii) = 1
999 ifinal(ii) = 0
1000 end if
1001 end do
1002 end if
1003 end if
1004
1005 if (present(lsize)) then
1006 lsize(1:nprocs) = ifinal(1:nprocs) - istart(1:nprocs) + 1
1007 assert(sum(lsize(1:nprocs)) == nobjs)
1008 end if
1009
1010 end subroutine multicomm_divide_range
1011
1012 ! ---------------------------------------------------------
1015 ! THREADSAFE
1016 subroutine multicomm_divide_range_omp(nobjs, ini, nobjs_loc)
1017 integer, intent(in) :: nobjs
1018 integer, intent(out) :: ini
1019 integer, intent(out) :: nobjs_loc
1020
1021 integer :: rank
1022#ifdef HAVE_OPENMP
1023 integer, allocatable :: istart(:), ifinal(:), lsize(:)
1024 integer :: nthreads
1025#endif
1026
1027 ! no push_sub, threadsafe
1028 rank = 1
1029#ifdef HAVE_OPENMP
1030 nthreads = omp_get_num_threads()
1031 allocate(istart(1:nthreads))
1032 allocate(ifinal(1:nthreads))
1033 allocate(lsize(1:nthreads))
1034 call multicomm_divide_range(nobjs, nthreads, istart, ifinal, lsize)
1035 rank = 1 + omp_get_thread_num()
1036 ini = istart(rank)
1037 nobjs_loc = lsize(rank)
1038 deallocate(istart)
1039 deallocate(ifinal)
1040 deallocate(lsize)
1041#else
1042 ini = 1
1043 nobjs_loc = nobjs
1044#endif
1045
1046 end subroutine multicomm_divide_range_omp
1047
1048 ! ---------------------------------------------------------
1049
1050 logical pure function multicomm_is_slave(this) result(slave)
1051 type(multicomm_t), intent(in) :: this
1052
1053 slave = this%node_type == p_slave
1054 end function multicomm_is_slave
1055
1056 ! ---------------------------------------------------------
1057
1058 logical pure function multicomm_have_slaves(this) result(have_slaves)
1059 type(multicomm_t), intent(in) :: this
1060
1061 have_slaves = this%have_slaves
1062 end function multicomm_have_slaves
1063
1064end module multicomm_oct_m
1065
1066
1067!! Local Variables:
1068!! mode: f90
1069!! coding: utf-8
1070!! End:
subroutine strategy()
Definition: multicomm.F90:464
subroutine group_comm_create()
Definition: multicomm.F90:676
subroutine sanity_check()
check if a balanced distribution of nodes will be used
Definition: multicomm.F90:599
subroutine assign_nodes()
Definition: multicomm.F90:523
This module contains interfaces for BLACS routines Interfaces are from http:
Definition: blacs.F90:27
This module handles the calculation mode.
integer, parameter, public p_strategy_max
integer, parameter, public p_strategy_kpoints
parallelization in k-points
integer, parameter, public p_strategy_other
something else like e-h pairs
integer, parameter, public p_strategy_domains
parallelization in domains
integer, parameter, public p_strategy_serial
single domain, all states, k-points on a single processor
integer, parameter, public p_strategy_states
parallelization in states
type(debug_t), save, public debug
Definition: debug.F90:158
real(real64), parameter, public m_one
Definition: global.F90:191
subroutine, public messages_print_with_emphasis(msg, iunit, namespace)
Definition: messages.F90:904
character(len=512), private msg
Definition: messages.F90:167
subroutine, public messages_warning(no_lines, all_nodes, namespace)
Definition: messages.F90:531
subroutine, public messages_obsolete_variable(namespace, name, rep)
Definition: messages.F90:1029
subroutine, public messages_new_line()
Definition: messages.F90:1118
character(len=256), dimension(max_lines), public message
to be output by fatal, warning
Definition: messages.F90:162
subroutine, public messages_fatal(no_lines, only_root_writes, namespace)
Definition: messages.F90:416
subroutine, public messages_experimental(name, namespace)
Definition: messages.F90:1069
subroutine, public messages_info(no_lines, iunit, debug_only, stress, all_nodes, namespace)
Definition: messages.F90:600
This module contains some common usage patterns of MPI routines.
Definition: mpi_lib.F90:117
subroutine mpi_grp_copy(mpi_grp_out, mpi_grp_in)
Definition: mpi.F90:348
type(mpi_comm), parameter, public mpi_comm_undefined
used to indicate a communicator has not been initialized
Definition: mpi.F90:138
type(mpi_grp_t), public mpi_world
Definition: mpi.F90:272
subroutine mpi_grp_init(grp, comm)
Initialize MPI group instance.
Definition: mpi.F90:310
This module handles the communicators for the various parallelization strategies.
Definition: multicomm.F90:147
logical pure function, public multicomm_strategy_is_parallel(mc, level)
Definition: multicomm.F90:719
integer, parameter, public p_slave
Definition: multicomm.F90:183
subroutine, public multicomm_divide_range(nobjs, nprocs, istart, ifinal, lsize, scalapack_compat)
This routine uses the one-factorization (or near-one-factorization of a complete graph to construct a...
Definition: multicomm.F90:739
subroutine, public multicomm_all_pairs_copy(apout, apin)
Definition: multicomm.F90:248
subroutine, public multicomm_end(mc)
Definition: multicomm.F90:697
integer, parameter, public par_no
Definition: multicomm.F90:187
logical pure function, public multicomm_have_slaves(this)
Definition: multicomm.F90:845
logical pure function, public multicomm_is_slave(this)
Definition: multicomm.F90:837
subroutine, public multicomm_init(mc, namespace, base_grp, mode_para, n_node, index_range, min_range)
create index and domain communicators
Definition: multicomm.F90:266
subroutine, public multicomm_divide_range_omp(nobjs, ini, nobjs_loc)
Function to divide the range of numbers from 1 to nobjs between all available threads with OpenMP.
Definition: multicomm.F90:815
This module is intended to contain simple general-purpose utility functions and procedures.
Definition: utils.F90:120
subroutine, public get_divisors(nn, n_divisors, divisors)
Definition: utils.F90:171
This is defined even when running serial.
Definition: mpi.F90:144
An all-pairs communication schedule for a given group.
Definition: multicomm.F90:237
Stores all communicators and groups.
Definition: multicomm.F90:208
int true(void)