I have been trying (with not much success) to do MPI reduction using a custom operation in Fortran 2008. I managed to do this in C, but information is a bit more scarce on Fortran 2008.
This code works with the included MPI_SUM reduction function. It simply sums each existing rank value into a global sum. My immediate goal would be to define a user function, to do basically the same. Any help?
program main
use mpi_f08
implicit none
integer :: ierror, isize, irank
integer :: local_value, global_value
call MPI_INIT(ierror)
call MPI_COMM_SIZE(MPI_COMM_WORLD, isize)
call MPI_COMM_RANK(MPI_COMM_WORLD, irank)
if (irank == 0) then
local_value = irank
global_value = 0
call MPI_Reduce(local_value, global_value, 1, MPI_INT, MPI_SUM, 0, MPI_COMM_WORLD, ierror)
print *, "global_value", global_value
else ! MPI if rank > 0
local_value = irank
call MPI_Reduce(local_value, global_value, 1, MPI_INT, MPI_SUM, 0, MPI_COMM_WORLD, ierror)
end if ! MPI if rank
call MPI_FINALIZE(ierror)
end program main
I managed to write a functional implementation in Fortran, but for some reason the output using 4 MPI processes was 3 instead of 6. No clue why. Still, I need a (correctly) working Fortran 2008 implementation to move forward.
EDIT - here is the fortran code that compiles, but does not run properly
program main
use mpi
implicit none
integer :: local_value, global_sum
integer :: ierr, rank, size
integer :: my_op
call MPI_Init(ierr)
call MPI_Comm_size(MPI_COMM_WORLD, size, ierr)
call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)
call MPI_Op_create(custom_sum_op, .true., my_op, ierr)
if (rank == 0) then
local_value = rank
global_sum = 0
call MPI_Reduce(local_value, global_sum, 1, MPI_INT, my_op, 0, MPI_COMM_WORLD, ierr)
print *, "Global sum: ", global_sum
else ! irank > 0
local_value = rank
call MPI_Reduce(local_value, global_sum, 1, MPI_INT, my_op, 0, MPI_COMM_WORLD, ierr)
endif ! MPI if rank 0
call MPI_Finalize(ierr)
contains
subroutine custom_sum_op(res, a)
integer, intent(inout) :: res
integer, intent(in) :: a
res = a + res
end subroutine custom_sum_op
end program main
Here's an example that works, with the interface for the user defined function taken from the MPI standard. What you have certainly doesn't match what the standard says; you only have 2 arguments instead of 4, they are of the wrong type for the mpi_f08 interface, and you are returning the result in the first argument, not the second.
ijb@ijb-Latitude-5410:~/work/stack$ cat op_create.f90
Module my_sum_module
Implicit None
Public :: my_sum
Private
Contains
Subroutine my_sum( invec, inoutvec, len, datatype )
Use, Intrinsic :: iso_fortran_env, Only : stdout => output_unit
Use, Intrinsic :: iso_C_binding , Only : c_ptr
Use mpi_f08
Implicit None
Type( c_ptr ) , Value :: invec
Type( c_ptr ) , Value :: inoutvec
Integer :: len
Type( mpi_datatype ) :: datatype
Integer, Dimension( : ), Pointer :: in_fptr
Integer, Dimension( : ), Pointer :: inout_fptr
If( datatype == mpi_integer ) Then
Call c_f_pointer( invec , in_fptr , [ len ] )
Call c_f_pointer( inoutvec, inout_fptr, [ len ] )
inout_fptr = inout_fptr + in_fptr
Else
Write( stdout, * ) 'Unkown data type in my_sum'
Call mpi_abort( mpi_comm_world, 5 )
End If
End Subroutine my_sum
End Module my_sum_module
Program test
Use, Intrinsic :: iso_fortran_env, Only : stdout => output_unit
Use mpi_f08, Only : mpi_comm_world
Use mpi_f08, Only : mpi_integer
Use mpi_f08, Only : mpi_sum
Use mpi_f08, Only : mpi_op
Use mpi_f08, Only : mpi_init, mpi_finalize
Use mpi_f08, Only : mpi_comm_rank, mpi_comm_size
Use mpi_f08, Only : mpi_reduce
Use mpi_f08, Only : mpi_op_create
Use my_sum_module, Only : my_sum
Implicit None
Type( mpi_op ) :: op
Integer :: root
Integer :: answer
Integer :: me, nproc
Call mpi_init()
Call mpi_comm_rank( mpi_comm_world, me )
Call mpi_comm_size( mpi_comm_world, nproc )
If( me == 0 ) Then
Write( stdout, * ) 'Running on', nproc, ' processes'
End If
root = 0
Call mpi_reduce( me, answer, 1, mpi_integer, mpi_sum, root, mpi_comm_world )
If( me == root ) Then
Write( stdout, * ) 'Answer to sum = ', answer
End If
Call mpi_op_create( my_sum, .True., op )
Call mpi_reduce( me, answer, 1, mpi_integer, op, root, mpi_comm_world )
If( me == root ) Then
Write( stdout, * ) 'Answer to my_sum = ', answer
End If
Call mpi_finalize()
End Program test
ijb@ijb-Latitude-5410:~/work/stack$ mpif90 --version
GNU Fortran (Ubuntu 9.4.0-1ubuntu1~20.04.2) 9.4.0
Copyright (C) 2019 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
ijb@ijb-Latitude-5410:~/work/stack$ mpif90 -Wall -Wextra -fcheck=all -O -g -std=f2018 op_create.f90
ijb@ijb-Latitude-5410:~/work/stack$ mpirun -np 1 ./a.out
Running on 1 processes
Answer to sum = 0
Answer to my_sum = 0
ijb@ijb-Latitude-5410:~/work/stack$ mpirun -np 2 ./a.out
Running on 2 processes
Answer to sum = 1
Answer to my_sum = 1
ijb@ijb-Latitude-5410:~/work/stack$ mpirun -np 3 ./a.out
Running on 3 processes
Answer to sum = 3
Answer to my_sum = 3
ijb@ijb-Latitude-5410:~/work/stack$ mpirun -np 4 ./a.out
Running on 4 processes
Answer to sum = 6
Answer to my_sum = 6
ijb@ijb-Latitude-5410:~/work/stack$ mpirun -np 5 --oversubscribe ./a.out
Running on 5 processes
Answer to sum = 10
Answer to my_sum = 10
ijb@ijb-Latitude-5410:~/work/stack$