-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathspawn_multiple_worker_fortran.f90
118 lines (91 loc) · 4.53 KB
/
spawn_multiple_worker_fortran.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
! Compile with:
! mpif90 -O2 -openmp -fpp spawn_multiple_worker_fortran.f90 -o spawn_multiple_worker_fortran
! This program is not designed to be a stand-alone process and will crash if it
! is not run as a child process.
! See worker_multiple.py for an analogous program written in python.
elemental subroutine str2int(str, int, stat)
implicit none
character(len=*), intent(in) :: str
integer, intent(out) :: int
integer, intent(out) :: stat
read(str, *, iostat=stat) int
end subroutine str2int
program split_worker
implicit none
include 'mpif.h'
integer :: ipvd, nthr, mpierr, stat
integer :: color, colored_comm, parent_comm
character(len=16) :: color_str
integer :: world_rank, colored_rank
integer :: world_nprocs, nprocs
integer :: root
integer, dimension(:), allocatable :: world_ranks, colored_ranks, world_colors, colors, temp
integer :: to_send
integer :: i, multiplier, length
character (len=256) :: argv1
double precision :: fraction, partial_pi, pi, pi_out, result, leftover_fraction
double precision, dimension(2) :: array_result
double precision, dimension(:,:), allocatable :: array_results
! Initialize MPI
call mpi_init_thread(MPI_THREAD_MULTIPLE, ipvd, mpierr)
call mpi_comm_rank(mpi_comm_world, world_rank, mpierr)
call mpi_comm_size(mpi_comm_world, world_nprocs, mpierr)
! Get the parent communicator
call mpi_comm_get_parent(parent_comm, mpierr)
! Read in this special environemnt variable set by OpenMPI
! Context: http://stackoverflow.com/questions/35924226/openmpi-mpmd-get-communication-size
! (See the solution by Hristo Iliev)
call get_environment_variable("OMPI_MCA_orte_app_num", color_str)
if(trim(color_str) .ne. "") then
call str2int(color_str, color, stat)
write(*,"(A,I2,A,I2)") "Found environment variable 'OMPI_MCA_orte_app_num' == ", color, " for rank ", world_rank
else
call get_command_argument(2, color_str, length, stat)
call str2int(color_str, multiplier, stat)
endif
! Split the world communicator into separate pieces for each subprogram
call mpi_barrier(mpi_comm_world, mpierr)
call mpi_comm_split(mpi_comm_world, color, world_rank, colored_comm, mpierr)
! Get each core's rank within its new communicator
call mpi_comm_rank(colored_comm, colored_rank, mpierr)
! Get the total number of cores (ie the sum of all the worlds)
call mpi_comm_size(colored_comm, nprocs, mpierr)
! Also set the root to 0 for every processor
root = 0
call get_command_argument(1, argv1, length, stat)
call str2int(argv1, multiplier, stat)
! All the communicators work. Here is a demonstration using barriers.
call mpi_barrier(parent_comm, mpierr)
call mpi_barrier(mpi_comm_world, mpierr)
call mpi_barrier(colored_comm, mpierr)
! See worker_multiple.py for details about this calculation
fraction = 1.0 / 2**(1+colored_rank)
partial_pi = fraction * 3.14159
call mpi_reduce(pi, pi_out, 1, MPI_DOUBLE, MPI_SUM, 0, colored_comm, mpierr)
pi = pi_out
write(*,"(A,I3,A,I3,A,I2,A,I3,A,I3,A,I3,A,F9.6)") "I am worker with world rank", world_rank, " of", world_nprocs, " and color", color, "; and rank", colored_rank, " of", nprocs, " in the colored communicator. I recieved", multiplier, " as my multiplier and calculated my portion of pi as", partial_pi
if(colored_rank .eq. root) then
leftover_fraction = 0.0
do i=0, nprocs-1
leftover_fraction = leftover_fraction + 1.0 / 2**(1+i)
enddo
leftover_fraction = 1.0 - leftover_fraction
pi = pi + leftover_fraction * 3.14159
endif
if(colored_rank .eq. 0) then
write(*,"(A,F15.12,A,I3,A,I2)") "The cores were not assigned to calculate ", 100.0*leftover_fraction ,"% of pi, so it has been added to the result by worker", colored_rank, " on color", color
endif
call mpi_bcast(pi, 1, MPI_DOUBLE, root, colored_comm, mpierr)
result = multiplier * pi
call mpi_barrier(parent_comm, mpierr)
array_result = (/dble(color), result/)
allocate(array_results(2, nprocs))
call mpi_gather(array_result, 2, MPI_DOUBLE, array_results, 2, MPI_DOUBLE, root, parent_comm, mpierr)
! Free the sub-communicators and finalize
call mpi_comm_free(colored_comm, mpierr)
if(parent_comm .ne. mpi_comm_null) then
call mpi_comm_disconnect(parent_comm, mpierr)
write(*,"(A,I3)") "Successfully disconnected worker", world_rank
endif
call mpi_finalize(mpierr)
end program split_worker