diff --git a/tutorials.md b/tutorials.md index e477fbe..37a2d99 100644 --- a/tutorials.md +++ b/tutorials.md @@ -30,3 +30,6 @@ The tutorials assume that the reader has a basic knowledge of C, some C++, and L ## Groups and communicators * [Introduction to groups and communicators]({{ site.baseurl }}/tutorials/introduction-to-groups-and-communicators/) ([中文版]({{ site.baseurl }}/tutorials/introduction-to-groups-and-communicators/zh_cn)) + +## MPI and Fortran +* [Introduction and differences for MPI Fortran]({{ site.baseurl }}/tutorials/mpi-fortran/) diff --git a/tutorials/mpi-fortran/code/all_avg.f90 b/tutorials/mpi-fortran/code/all_avg.f90 new file mode 100644 index 0000000..8dc44a5 --- /dev/null +++ b/tutorials/mpi-fortran/code/all_avg.f90 @@ -0,0 +1,88 @@ +program main + use mpi_f08 + use iso_fortran_env, only: error_unit + + implicit none + + interface + function compute_avg(array, num_elements) + real :: compute_avg + integer, intent(in) :: num_elements + real, intent(in) :: array(num_elements) + end function compute_avg + end interface + + integer :: num_args + character(12) :: arg + integer :: num_elements_per_proc + integer :: world_size, world_rank + real :: sub_avg, avg + real, allocatable :: rand_nums(:), sub_rand_nums(:), sub_avgs(:) + + num_args = command_argument_count() + + if (num_args .ne. 1) then + write (error_unit, *) 'Usage: all_avg num_elements_per_proc' + stop + end if + + call get_command_argument(1, arg) + + read (arg, *) num_elements_per_proc + ! Seed the random number generator to get different results each time + call random_seed() + + call MPI_INIT() + + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + ! Create a random array of elements on the root process. Its total + ! size will be the number of elements per process times the number + ! of processes + if (world_rank .eq. 0) then + allocate(rand_nums(num_elements_per_proc * world_size)) + call random_number(rand_nums) + end if + + allocate(sub_rand_nums(num_elements_per_proc)) + + call MPI_Scatter(rand_nums, num_elements_per_proc, MPI_FLOAT, sub_rand_nums, & + num_elements_per_proc, MPI_FLOAT, 0, MPI_COMM_WORLD) + + ! Compute the average of your subset + sub_avg = compute_avg(sub_rand_nums, num_elements_per_proc) + + ! Gather all partial averages down to all the processes + allocate(sub_avgs(world_size)) + call MPI_Allgather(sub_avg, 1, MPI_FLOAT, sub_avgs, 1, MPI_FLOAT, MPI_COMM_WORLD) + + ! Now that we have all of the partial averages, compute the + ! total average of all numbers. Since we are assuming each process computed + ! an average across an equal amount of elements, this computation will + ! produce the correct answer. + avg = compute_avg(sub_avgs, world_size) + print '("Avg of all elements from proc ", I0, " is ", ES12.5)', world_rank, avg + + ! Clean up + if (world_rank .eq. 0) then + deallocate(rand_nums) + end if + deallocate(sub_avgs) + deallocate(sub_rand_nums) + + call MPI_Barrier(MPI_COMM_WORLD) + call MPI_FINALIZE() + +end program main + + +function compute_avg(array, num_elements) + ! Computes the average of an array of numbers + implicit none + real :: compute_avg + integer, intent(in) :: num_elements + real, intent(in) :: array(num_elements) + + compute_avg = sum(array) / real(num_elements) +end function compute_avg diff --git a/tutorials/mpi-fortran/code/avg.f90 b/tutorials/mpi-fortran/code/avg.f90 new file mode 100644 index 0000000..b98a218 --- /dev/null +++ b/tutorials/mpi-fortran/code/avg.f90 @@ -0,0 +1,95 @@ + +program main + use mpi_f08 + use iso_fortran_env, only: error_unit + + implicit none + + interface + function compute_avg(array, num_elements) + real :: compute_avg + integer, intent(in) :: num_elements + real, intent(in) :: array(num_elements) + end function + end interface + + integer :: num_args + character(12) :: arg + integer :: num_elements_per_proc + integer :: world_size, world_rank + real :: sub_avg, avg, original_data_avg + real, allocatable :: rand_nums(:), sub_rand_nums(:), sub_avgs(:) + + num_args = command_argument_count() + + if (num_args .ne. 1) then + write (error_unit, *) 'Usage: avg num_elements_per_proc' + stop + end if + + call get_command_argument(1, arg) + + read (arg, *) num_elements_per_proc + ! Seed the random number generator to get different results each time + call random_seed() + + call MPI_INIT() + + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + ! Create a random array of elements on the root process. Its total + ! size will be the number of elements per process times the number + ! of processes + if (world_rank .eq. 0) then + allocate(rand_nums(num_elements_per_proc * world_size)) + call random_number(rand_nums) + end if + + allocate(sub_rand_nums(num_elements_per_proc)) + + call MPI_Scatter(rand_nums, num_elements_per_proc, MPI_FLOAT, sub_rand_nums, & + num_elements_per_proc, MPI_FLOAT, 0, MPI_COMM_WORLD) + + ! Compute the average of your subset + sub_avg = compute_avg(sub_rand_nums, num_elements_per_proc) + + ! Gather all partial averages down to the root process + if (world_rank .eq. 0) then + allocate(sub_avgs(world_size)) + end if + call MPI_Gather(sub_avg, 1, MPI_FLOAT, sub_avgs, 1, MPI_FLOAT, 0, MPI_COMM_WORLD) + + ! Now that we have all of the partial averages on the root, compute the + ! total average of all numbers. Since we are assuming each process computed + ! an average across an equal amount of elements, this computation will + ! produce the correct answer. + if (world_rank .eq. 0) then + avg = compute_avg(sub_avgs, world_size) + print '("Avg of all elements is ", ES12.5)', avg + ! Compute the average across the original data for comparison + original_data_avg = compute_avg(rand_nums, num_elements_per_proc * world_size) + print '("Avg computed across original data is ", ES12.5)', avg + end if + + ! Clean up + if (world_rank .eq. 0) then + deallocate(rand_nums) + deallocate(sub_avgs) + end if + deallocate(sub_rand_nums) + + call MPI_Barrier(MPI_COMM_WORLD) + call MPI_FINALIZE() + +end program main + +function compute_avg(array, num_elements) + ! Computes the average of an array of numbers + implicit none + real :: compute_avg + integer, intent(in) :: num_elements + real, intent(in) :: array(num_elements) + + compute_avg = sum(array) / real(num_elements) +end function compute_avg diff --git a/tutorials/mpi-fortran/code/check_status.f90 b/tutorials/mpi-fortran/code/check_status.f90 new file mode 100644 index 0000000..100196e --- /dev/null +++ b/tutorials/mpi-fortran/code/check_status.f90 @@ -0,0 +1,46 @@ +program check_status + use mpi_f08 + + implicit none + + integer :: world_rank, world_size + integer, parameter :: MAX_NUMBERS=100 + integer :: numbers(MAX_NUMBERS) + integer :: number_amount + type(MPI_Status) :: recv_status + + real :: r + + call MPI_INIT() + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + + if (world_rank .eq. 0) then + ! Pick a random amount of integers to send to process one + call random_seed() + + call random_number(r) + number_amount = int(r * real(MAX_NUMBERS)) + ! Send the amount of integers to process one + call MPI_SEND(numbers, number_amount, MPI_INT, 1, 9, & + MPI_COMM_WORLD) + print '("0 sent ", I0, " numbers to 1")', number_amount + else if (world_rank .eq. 1) then + ! Receive at most MAX_NUMBERS from process zero + call MPI_RECV(numbers, MAX_NUMBERS, MPI_INT, 0, 9, & + MPI_COMM_WORLD, recv_status) + ! After receiving the message, check the status to determine how many + ! numbers were actually received + call MPI_Get_count(recv_status, MPI_INT, number_amount) + ! Print off the amount of numbers, and also print additional information + ! in the status object + print '("1 received ", I0, " numbers from 0. Message source = ", I0, ", tag = ", I0)', & + number_amount , recv_status%MPI_SOURCE , recv_status%MPI_TAG + end if + + call MPI_Barrier(MPI_COMM_WORLD) + + call MPI_FINALIZE() + +end program diff --git a/tutorials/mpi-fortran/code/comm_groups.f90 b/tutorials/mpi-fortran/code/comm_groups.f90 new file mode 100644 index 0000000..e2545bc --- /dev/null +++ b/tutorials/mpi-fortran/code/comm_groups.f90 @@ -0,0 +1,51 @@ +program main + use mpi_f08 + + implicit none + + integer :: world_rank, world_size + type(MPI_Group) :: world_group, prime_group + type(MPI_Comm) :: prime_comm + integer, parameter :: n = 7 + integer :: ranks(n) + integer :: prime_rank, prime_size + + call MPI_Init() + + ! Get the rank and size in the original communicator + call MPI_Comm_rank(MPI_COMM_WORLD, world_rank) + call MPI_Comm_size(MPI_COMM_WORLD, world_size) + + ! Get the group of processes in MPI_COMM_WORLD + call MPI_Comm_group(MPI_COMM_WORLD, world_group) + + ranks = [1, 2, 3, 5, 7, 11, 13] + + ! Construct a group containing all of the prime ranks in world_group + call MPI_Group_incl(world_group, 7, ranks, prime_group) + + ! Create a new communicator based on the group + call MPI_Comm_create_group(MPI_COMM_WORLD, prime_group, 0, prime_comm) + + prime_rank = -1 + prime_size = -1 + ! If this rank isn't in the new communicator, it will be MPI_COMM_NULL + ! Using MPI_COMM_NULL for MPI_Comm_rank or MPI_Comm_size is erroneous + if (MPI_COMM_NULL .ne. prime_comm) then + call MPI_Comm_rank(prime_comm, prime_rank) + call MPI_Comm_size(prime_comm, prime_size) + end if + + print '("WORLD RANK/SIZE: ", I0, "/", I0, " --- PRIME RANK/SIZE: ", I0, "/", I0)', & + world_rank, world_size, prime_rank, prime_size + + call MPI_Group_free(world_group) + call MPI_Group_free(prime_group) + + if (MPI_COMM_NULL .ne. prime_comm) then + call MPI_Comm_free(prime_comm) + end if + + call MPI_Finalize() + +end program main diff --git a/tutorials/mpi-fortran/code/comm_split.f90 b/tutorials/mpi-fortran/code/comm_split.f90 new file mode 100644 index 0000000..3551ab4 --- /dev/null +++ b/tutorials/mpi-fortran/code/comm_split.f90 @@ -0,0 +1,32 @@ +program main + use mpi_f08 + + implicit none + + integer :: world_rank, world_size + integer :: color + type(MPI_Comm) :: row_comm + integer :: row_rank, row_size + + call MPI_INIT() + + ! Get the rank and size in the original communicator + call MPI_Comm_rank(MPI_COMM_WORLD, world_rank) + call MPI_Comm_size(MPI_COMM_WORLD, world_size) + + color = world_rank / 4 ! Determine color based on row + + ! Split the communicator based on the color and use the original rank for ordering + call MPI_Comm_split(MPI_COMM_WORLD, color, world_rank, row_comm) + + call MPI_Comm_rank(row_comm, row_rank) + call MPI_Comm_size(row_comm, row_size) + + print '("WORLD RANK/SIZE: ", I0, "/", I0, " --- ROW RANK/SIZE: ", I0, "/", I0)', & + world_rank, world_size, row_rank, row_size + + call MPI_Comm_free(row_comm) + + call MPI_Finalize() + +end program main diff --git a/tutorials/mpi-fortran/code/compare_bcast.f90 b/tutorials/mpi-fortran/code/compare_bcast.f90 new file mode 100644 index 0000000..15e5172 --- /dev/null +++ b/tutorials/mpi-fortran/code/compare_bcast.f90 @@ -0,0 +1,104 @@ +program main + use mpi_f08 + use iso_fortran_env, only: error_unit + + implicit none + interface + subroutine my_bcast(data, count, datatype, root, communicator, ierror) + import MPI_Comm, MPI_Datatype + implicit none + integer, intent (in) :: count, root + type(MPI_Comm), intent (in) :: communicator + type(MPI_Datatype), intent (in) :: datatype + integer, intent (inout) :: data(count) + integer, intent (out) :: ierror + end subroutine my_bcast + end interface + + integer :: num_args, num_elements, num_trials + character(12) :: args(2) + integer :: world_rank, ierror + double precision :: total_my_bcast_time, total_mpi_bcast_time + integer :: i + integer, allocatable :: data(:) + + num_args = command_argument_count() + + if (num_args .ne. 2) then + write (error_unit, *) 'Usage: compare_bcast num_elements num_trials' + stop + end if + + call get_command_argument(1, args(1)) + call get_command_argument(2, args(2)) + + read (args(1), *) num_elements + read (args(2), *) num_trials + + call MPI_INIT() + + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + total_my_bcast_time = 0.0 + total_mpi_bcast_time = 0.0 + + allocate(data(num_elements)) + + do i = 1, num_trials + ! Time my_bcast + ! Synchronize before starting timing + call MPI_Barrier(MPI_COMM_WORLD) + total_my_bcast_time = total_my_bcast_time - MPI_Wtime() + call my_bcast(data, num_elements, MPI_INT, 0, MPI_COMM_WORLD, ierror) + ! Synchronize again before obtaining final time + call MPI_Barrier(MPI_COMM_WORLD) + total_my_bcast_time = total_my_bcast_time + MPI_Wtime() + + ! Time MPI_Bcast + call MPI_Barrier(MPI_COMM_WORLD) + total_mpi_bcast_time = total_mpi_bcast_time - MPI_Wtime() + call MPI_Bcast(data, num_elements, MPI_INT, 0, MPI_COMM_WORLD, ierror) + call MPI_Barrier(MPI_COMM_WORLD) + total_mpi_bcast_time = total_mpi_bcast_time + MPI_Wtime() + end do + + ! Print off timing information + if (world_rank .eq. 0) then + print '("Data size = ", I0, ", Trials = ", I0)', num_elements, num_trials + print '("Avg my_bcast time = ", ES12.5)', total_my_bcast_time / num_trials + print '("Avg mpi_bcast time = ", ES12.5)', total_mpi_bcast_time / num_trials + end if + + ! Finalize the MPI environment + + call MPI_FINALIZE() + +end program + +subroutine my_bcast(data, count, datatype, root, communicator, ierror) + use mpi_f08 + implicit none + integer, intent (in) :: count, root + type(MPI_Comm), intent (in) :: communicator + type(MPI_Datatype), intent (in) :: datatype + integer, intent (inout) :: data(count) + integer, intent (out) :: ierror + + integer :: world_rank, world_size + integer :: i + + call MPI_COMM_SIZE(communicator, world_size, ierror) + call MPI_COMM_RANK(communicator, world_rank, ierror) + + if (world_rank .eq. root) then + ! If we are the root process, send our data to everyone + do i = 0, world_size - 1 + if (i .ne. world_rank) then + call MPI_SEND(data, count, datatype, i, 0, communicator, ierror) + end if + end do + else + ! If we are a receiver process, receive the data from the root + call MPI_RECV(data, count, datatype, root, 0, communicator, MPI_STATUS_IGNORE, ierror) + end if +end subroutine my_bcast \ No newline at end of file diff --git a/tutorials/mpi-fortran/code/makefile b/tutorials/mpi-fortran/code/makefile new file mode 100644 index 0000000..3cf5eb8 --- /dev/null +++ b/tutorials/mpi-fortran/code/makefile @@ -0,0 +1,52 @@ +EXECS=mpi_hello_world send_recv ping_pong ring check_status probe \ + my_bcast compare_bcast avg all_avg reduce_avg reduce_std \ + comm_split comm_groups +MPIF90?=mpif90 +FFLAGS=-Wall + +all: $(EXECS) + +mpi_hello_world: mpi_hello_world.f90 + $(MPIF90) $(FFLAGS) mpi_hello_world.f90 -o mpi_hello_world + +send_recv: send_recv.f90 + $(MPIF90) $(FFLAGS) send_recv.f90 -o send_recv + +ping_pong: ping_pong.f90 + $(MPIF90) $(FFLAGS) ping_pong.f90 -o ping_pong + +ring: ring.f90 + $(MPIF90) $(FFLAGS) ring.f90 -o ring + +check_status: check_status.f90 + $(MPIF90) $(FFLAGS) check_status.f90 -o check_status + +probe: probe.f90 + $(MPIF90) $(FFLAGS) probe.f90 -o probe + +my_bcast: my_bcast.f90 + $(MPIF90) $(FFLAGS) my_bcast.f90 -o my_bcast + +compare_bcast: compare_bcast.f90 + $(MPIF90) $(FFLAGS) compare_bcast.f90 -o compare_bcast + +avg: avg.f90 + $(MPIF90) $(FFLAGS) avg.f90 -o avg + +all_avg: all_avg.f90 + $(MPIF90) $(FFLAGS) all_avg.f90 -o all_avg + +reduce_avg: reduce_avg.f90 + $(MPIF90) $(FFLAGS) reduce_avg.f90 -o reduce_avg + +reduce_std: reduce_std.f90 + $(MPIF90) $(FFLAGS) reduce_std.f90 -o reduce_std + +comm_split: comm_split.f90 + $(MPIF90) $(FFLAGS) comm_split.f90 -o comm_split + +comm_groups: comm_groups.f90 + $(MPIF90) $(FFLAGS) comm_groups.f90 -o comm_groups + +clean: + rm -f $(EXECS) diff --git a/tutorials/mpi-fortran/code/mpi_hello_world.f90 b/tutorials/mpi-fortran/code/mpi_hello_world.f90 new file mode 100644 index 0000000..f5cb97b --- /dev/null +++ b/tutorials/mpi-fortran/code/mpi_hello_world.f90 @@ -0,0 +1,30 @@ +program hello_world_mpi + use mpi_f08 + + implicit none + + integer :: world_rank, world_size + integer :: name_len + + character (len=MPI_MAX_PROCESSOR_NAME) :: processor_name + + ! Initialize the MPI environment + call MPI_INIT() + + ! Get the number of processes + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + + ! Get the rank of the process + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + ! Get the name of the processor + call MPI_GET_PROCESSOR_NAME(processor_name, name_len) + + ! Print off an hello world message + print '("Hello world from processor ", A, ", rank ", I0, " out of ", I0, " processors")', & + processor_name(:name_len), world_rank, world_size + + ! Finalize the MPI environment + call MPI_FINALIZE() + +end program diff --git a/tutorials/mpi-fortran/code/my_bcast.f90 b/tutorials/mpi-fortran/code/my_bcast.f90 new file mode 100644 index 0000000..e0ef8d3 --- /dev/null +++ b/tutorials/mpi-fortran/code/my_bcast.f90 @@ -0,0 +1,66 @@ +program main + use mpi_f08 + + implicit none + + interface + subroutine my_bcast(data, count, datatype, root, communicator, ierror) + import MPI_Comm, MPI_Datatype + implicit none + integer, intent (in) :: count, root + type(MPI_Comm), intent (in) :: communicator + type(MPI_Datatype), intent (in) :: datatype + integer, intent (inout) :: data(count) + integer, intent (out) :: ierror + end subroutine my_bcast + end interface + + integer :: world_rank, ierror + integer :: data(1) + + call MPI_INIT() + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + if (world_rank .eq. 0) then + data = 100 + print '("Process 0 broadcasting data ", I0)', data + call my_bcast(data, 1, MPI_INT, 0, MPI_COMM_WORLD, ierror) + else + call my_bcast(data, 1, MPI_INT, 0, MPI_COMM_WORLD, ierror) + print '("Process ", I0, " received data ", I0, " from root process")', & + world_rank, data + end if + + ! Finalize the MPI environment + call MPI_FINALIZE() + +end program + + +subroutine my_bcast(data, count, datatype, root, communicator, ierror) + use mpi_f08 + implicit none + integer, intent (in) :: count, root + type(MPI_Comm), intent (in) :: communicator + type(MPI_Datatype), intent (in) :: datatype + integer, intent (inout) :: data(count) + integer, intent (out) :: ierror + + integer :: world_rank, world_size + integer :: i + + call MPI_COMM_SIZE(communicator, world_size, ierror) + call MPI_COMM_RANK(communicator, world_rank, ierror) + + if (world_rank .eq. root) then + ! If we are the root process, send our data to everyone + do i = 0, world_size - 1 + if (i .ne. world_rank) then + call MPI_SEND(data, count, datatype, i, 0, communicator, ierror) + end if + end do + else + ! If we are a receiver process, receive the data from the root + call MPI_RECV(data, count, datatype, root, 0, communicator, MPI_STATUS_IGNORE, ierror) + end if +end subroutine my_bcast diff --git a/tutorials/mpi-fortran/code/ping_pong.f90 b/tutorials/mpi-fortran/code/ping_pong.f90 new file mode 100644 index 0000000..d15365e --- /dev/null +++ b/tutorials/mpi-fortran/code/ping_pong.f90 @@ -0,0 +1,39 @@ +program ping_pong + use mpi_f08 + + implicit none + + integer :: world_rank, world_size + integer :: partner_rank + integer :: ping_pong_count, ping_pong_limit + type(MPI_Status) :: recv_status + + + call MPI_INIT() + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + ping_pong_count = 0 + ping_pong_limit = 10 + + partner_rank = mod(world_rank + 1, 2) + + do while (ping_pong_count .lt. ping_pong_limit) + if (world_rank .eq. mod(ping_pong_count, 2)) then + ! Increment the ping pong count before you send it + ping_pong_count = ping_pong_count + 1 + call MPI_SEND(ping_pong_count, 1, MPI_INT, partner_rank, 0, & + MPI_COMM_WORLD) + print '(I0, " sent and incremented ping_pong_count ", I0, " to ", I0)', & + world_rank, ping_pong_count, partner_rank + else + call MPI_RECV(ping_pong_count, 1, MPI_INT, partner_rank, 0, & + MPI_COMM_WORLD, recv_status) + print '(I0, " received ping_pong_count ", I0, " from ", I0)', & + world_rank, ping_pong_count, partner_rank + end if + end do + + call MPI_FINALIZE() + +end program diff --git a/tutorials/mpi-fortran/code/probe.f90 b/tutorials/mpi-fortran/code/probe.f90 new file mode 100644 index 0000000..854b894 --- /dev/null +++ b/tutorials/mpi-fortran/code/probe.f90 @@ -0,0 +1,51 @@ +program probe + use mpi_f08 + + implicit none + + integer :: world_rank, world_size + integer, parameter :: MAX_NUMBERS=100 + integer, allocatable :: numbers(:) + integer :: number_amount + type(MPI_Status) :: recv_status + + real :: r + + call MPI_INIT() + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + + if (world_rank .eq. 0) then + ! Pick a random amount of integers to send to process one + call random_seed() + + call random_number(r) + number_amount = int(r * real(MAX_NUMBERS)) + allocate(numbers(MAX_NUMBERS)) + ! Send the random amount of integers to process one + call MPI_SEND(numbers, number_amount, MPI_INT, 1, 0, & + MPI_COMM_WORLD) + print '("0 sent ", I0, " numbers to 1")', number_amount + else if (world_rank .eq. 1) then + ! Probe for an incoming message from process zero + call MPI_PROBE(0, 0, MPI_COMM_WORLD, recv_status) + + ! When probe returns, the status object has the size and other + ! attributes of the incoming message. Get the message size + call MPI_Get_count(recv_status, MPI_INT, number_amount) + + ! Allocate a buffer to hold the incoming numbers + allocate(numbers(number_amount)) + + ! Now receive the message with the allocated buffer + call MPI_RECV(numbers, number_amount, MPI_INT, 0, 0, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE) + print '("1 dynamically received ", I0, " numbers from 0.")', & + number_amount + deallocate(numbers) + end if + + call MPI_FINALIZE() + +end program diff --git a/tutorials/mpi-fortran/code/reduce_avg.f90 b/tutorials/mpi-fortran/code/reduce_avg.f90 new file mode 100644 index 0000000..0803dbc --- /dev/null +++ b/tutorials/mpi-fortran/code/reduce_avg.f90 @@ -0,0 +1,59 @@ +program main + use mpi_f08 + use iso_fortran_env, only: error_unit + use subs + + implicit none + + integer :: num_args + character(12) :: arg + integer :: num_elements_per_proc + integer :: world_size, world_rank + real :: local_sum, global_sum + real, allocatable :: rand_nums(:) + + num_args = command_argument_count() + + if (num_args .ne. 1) then + write (error_unit, *) 'Usage: reduce_avg num_elements_per_proc' + stop + end if + + call get_command_argument(1, arg) + read (arg, *) num_elements_per_proc + + call MPI_INIT() + + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + ! Create a random array of elements on all processes. + call random_seed() ! Seed the random number generator to get different results each time for each processor + allocate(rand_nums(num_elements_per_proc)) + call random_number(rand_nums) + + ! Sum the numbers locally + local_sum = sum(rand_nums) + + ! Print the random numbers on each process + print '("Local sum for process ", I0, " - ", ES12.5, ", avg = ", ES12.5)', & + world_rank, local_sum, local_sum / real(num_elements_per_proc) + + + ! Reduce all of the local sums into the global sum + call MPI_Reduce(local_sum, global_sum, 1, MPI_FLOAT, MPI_SUM, 0, & + MPI_COMM_WORLD) + + ! Print the result + if (world_rank .eq. 0) then + print '("Total sum = ", ES12.5, ", avg = ", ES12.5)', global_sum, & + global_sum / (world_size * num_elements_per_proc) + end if + + ! Clean up + deallocate(rand_nums) + + call MPI_Barrier(MPI_COMM_WORLD) + call MPI_FINALIZE() + +end program main diff --git a/tutorials/mpi-fortran/code/reduce_std.f90 b/tutorials/mpi-fortran/code/reduce_std.f90 new file mode 100644 index 0000000..1d6ad02 --- /dev/null +++ b/tutorials/mpi-fortran/code/reduce_std.f90 @@ -0,0 +1,70 @@ +program main + use mpi_f08 + use iso_fortran_env, only: error_unit + use subs + + implicit none + + integer :: num_args + character(12) :: arg + integer :: num_elements_per_proc + integer :: world_size, world_rank + real :: local_sum, global_sum, mean, local_sq_diff, global_sq_diff, stddev + real, allocatable :: rand_nums(:) + integer :: i + + num_args = command_argument_count() + + if (num_args .ne. 1) then + write (error_unit, *) 'Usage: reduce_std num_elements_per_proc' + stop + end if + + call get_command_argument(1, arg) + read (arg, *) num_elements_per_proc + + call MPI_INIT() + + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + + ! Create a random array of elements on all processes. + call random_seed() ! Seed the random number generator of processes uniquely + allocate(rand_nums(num_elements_per_proc)) + call random_number(rand_nums) + + ! Sum the numbers locally + local_sum = sum(rand_nums) + + ! Reduce all of the local sums into the global sum in order to + ! calculate the mean + call MPI_Allreduce(local_sum, global_sum, 1, MPI_FLOAT, MPI_SUM, & + MPI_COMM_WORLD) + mean = global_sum / real(num_elements_per_proc * world_size) + + ! Compute the local sum of the squared differences from the mean + local_sq_diff = 0.0 + do i = 1, num_elements_per_proc + local_sq_diff = local_sq_diff + (rand_nums(i) - mean) * (rand_nums(i) - mean) + end do + + ! Reduce the global sum of the squared differences to the root process + ! and print off the answer + call MPI_Reduce(local_sq_diff, global_sq_diff, 1, MPI_FLOAT, MPI_SUM, 0, & + MPI_COMM_WORLD) + + ! The standard deviation is the square root of the mean of the squared + ! differences + if (world_rank .eq. 0) then + stddev = sqrt(global_sq_diff / (num_elements_per_proc * world_size)) + print '("Mean - ", ES12.5, ", Standard deviation = ", ES12.5)', & + mean, stddev + end if + + ! Clean up + deallocate(rand_nums) + + call MPI_Barrier(MPI_COMM_WORLD) + call MPI_FINALIZE() + +end program main diff --git a/tutorials/mpi-fortran/code/ring.f90 b/tutorials/mpi-fortran/code/ring.f90 new file mode 100644 index 0000000..f751e4e --- /dev/null +++ b/tutorials/mpi-fortran/code/ring.f90 @@ -0,0 +1,39 @@ +program ring + use mpi_f08 + + implicit none + + integer :: world_rank, world_size + integer :: token + type(MPI_Status) :: recv_status + + + call MPI_INIT() + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + + if (world_rank .ne. 0) then + call MPI_RECV(token, 1, MPI_INT, world_rank - 1, 0, & + MPI_COMM_WORLD, recv_status) + print '("Process ", I0, " received token ", I0, " from process ", I0)', & + world_rank, token, world_rank - 1 + else + ! Set the token's value if you are process 0 + token = -1 + end if + + call MPI_SEND(token, 1, MPI_INT, mod(world_rank + 1, world_size), 0, & + MPI_COMM_WORLD) + + ! Now process 0 can receive from the last process. + if (world_rank .eq. 0) then + call MPI_RECV(token, 1, MPI_INT, world_size - 1, 0, & + MPI_COMM_WORLD, recv_status) + print '("Process ", I0, " received token ", I0, " from process ", I0)', & + world_rank, token, world_size - 1 + end if + + call MPI_FINALIZE() + +end program diff --git a/tutorials/mpi-fortran/code/send_recv.f90 b/tutorials/mpi-fortran/code/send_recv.f90 new file mode 100644 index 0000000..f821273 --- /dev/null +++ b/tutorials/mpi-fortran/code/send_recv.f90 @@ -0,0 +1,27 @@ +program send_recv + use mpi_f08 + + implicit none + + integer :: world_rank, world_size + integer :: num + type(MPI_Status) :: recv_status + + + call MPI_INIT() + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + if (world_rank .eq. 0) then + num = -1 + call MPI_SEND(num, 1, MPI_INT, 1, 0, & + MPI_COMM_WORLD) + else if (world_rank .eq. 1) then + call MPI_RECV(num, 1, MPI_INT, 0, 0, & + MPI_COMM_WORLD, recv_status) + print '("Process 1 received number ", I0, " from process 0")', num + end if + + call MPI_FINALIZE() + +end program diff --git a/tutorials/mpi-fortran/index.md b/tutorials/mpi-fortran/index.md new file mode 100644 index 0000000..803b137 --- /dev/null +++ b/tutorials/mpi-fortran/index.md @@ -0,0 +1,161 @@ +--- +layout: post +title: Using MPI with Fortran +author: Stephen Cook +categories: Beginner MPI +tags: +translations: +redirect_from: '/mpi-fortran/' +--- + +The MPI specification defines bindings for use within Fortran, a programming language frequently used for scientific computing. +In this tutorial, we shall see some of the specifics for using MPI with Fortran, focussing on the similarities and differences compared to the C binding covered in the other tutorials. + +> **Note** - Fortran versions of most of the MPI example code is provided on [GitHub]({{ site.github.repo }}) under [tutorials/mpi-fortran/code]({{ site.github.code }}/tutorials/mpi-fortran/code). + +## Fortran Hello World code example + +We shall first have a look at the Fortran 2008 version of a Hello World located in [mpi_hello_world.f90]({{ site.github.code }}/tutorials/mpi-fortran/code/mpi_hello_world.f90). + +```fortran +program hello_world_mpi + use mpi_f08 + + implicit none + + integer :: world_rank, world_size + integer :: name_len + + character (len=MPI_MAX_PROCESSOR_NAME) :: processor_name + + ! Initialize the MPI environment + call MPI_INIT() + + ! Get the number of processes + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + + ! Get the rank of the process + call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank) + + ! Get the name of the processor + call MPI_GET_PROCESSOR_NAME(processor_name, name_len) + + ! Print off an hello world message + print '("Hello world from processor ", A, ", rank ", I0, " out of ", I0, " processors")', & + processor_name(:name_len), world_rank, world_size + + ! Finalize the MPI environment + call MPI_FINALIZE() + +end program +``` + +Comparing this with the equivalent C code in [mpi_hello_world.c]({{ site.github.code }}/tutorials/mpi-hello-world/code/mpi_hello_world.c): + +```c +#include +#include + +int main(int argc, char** argv) { + // Initialize the MPI environment + MPI_Init(NULL, NULL); + + // Get the number of processes + int world_size; + MPI_Comm_size(MPI_COMM_WORLD, &world_size); + + // Get the rank of the process + int world_rank; + MPI_Comm_rank(MPI_COMM_WORLD, &world_rank); + + // Get the name of the processor + char processor_name[MPI_MAX_PROCESSOR_NAME]; + int name_len; + MPI_Get_processor_name(processor_name, &name_len); + + // Print off a hello world message + printf("Hello world from processor %s, rank %d out of %d processors\n", + processor_name, world_rank, world_size); + + // Finalize the MPI environment. + MPI_Finalize(); +} +``` + +We see many similarities but a few important differences. + +## Importing and initializing MPI + +In order to make MPI calls from within a Fortran program, the library must be imported and then initialized. + +The modern implementation of MPI was introduced with MPI 3.0 and Fortran 2008, and is imported into the program with + +```fortran +USE mpi_f08 +``` + +The fortran binding to the MPI routines are implemented as subroutines, and require the syntax + +```fortran +call MPI_XXXXXX() +``` + +> **Note** - Unlike C, Fortran is case insensitive. We adopt the convention of using all-capital names of the MPI routines. + +As an example, the first few lines of a fortran MPI program may look like this: + +```fortran +use mpi_f08 +implicit none +call MPI_INIT() +``` + +All the Fortran routines have an optional argument to return an error-code, so the above could could also be + +```fortran +use mpi_f08 +implicit none +integer :: ierror +call MPI_INIT(ierror) +``` + +The routine `MPI_INIT` has no required arguments and an error code can be returned as an optional argument. +Compare this with the C function `MPI_Init` which has two required arguments (the number of command-line arguments and a list of these as character arrays) and can optionally give the error code as the return value. + +## Other MPI routines + +Despite the differences in arguments required by the C and Fortran versions of `MPI_Init`, most other Fortran MPI routines share similar interfaces as the C implementations. +Again, the Fortran 2008 routines all end in the optional argument `IERROR`. + +```fortran +program hello_world_mpi + use mpi_f08 + integer :: world_size + call MPI_INIT() + + ! Get the number of processes + call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size) + ! Alternatively: + ! MPI_COMM_SIZE(MPI_COMM_WORLD, world_size, ierror) +``` + +Fortran versions of most of the C MPI example code from these tutorials has been translated to Fortran and is provided on [GitHub]({{ site.github.repo }}) under [tutorials/mpi-fortran/code]({{ site.github.code }}/tutorials/mpi-fortran/code). +These have mostly been written to mirror the C versions, with some Fortran-specific functionality added where it does not impact the MPI code (such as using the fortran function `sum` instead of performing a summation in a loop). + +## Older MPI implementations + +Prior to the introduction of `mpi_f08`, the library was imported with the syntax + +```fortran +USE mpi +``` + +or the Fortran77 compatible + +```fortran +INCLUDE 'mpif.h' +``` + +In the older versions of the interface (both `mpi` and `mpif.h`), most of the arguments such as the communicator object or the probe return status are integers or arrays of integers. +In the newer syntax, these objects are implemented as custom typedefs (as in the C interface) leading to better compile-time argument checking. +There is also an error code returned with all MPI calls, which is a required argument in the older versions, and an optional argument in the modern implementation.