我一直在尝试（没有取得多大成功）使用 Fortran 2008 中的自定义操作来减少 MPI。我设法用 C 语言做到这一点，但 Fortran 2008 上的信息有点稀缺。
此代码与包含的 MPI_SUM 归约函数一起使用。它只是将每个现有的排名值求和为全局总和。我的直接目标是定义一个用户函数，基本上做同样的事情。有什么帮助吗？
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
我设法用 Fortran 编写了一个功能实现，但由于某种原因，使用 4 个 MPI 进程的输出是 3 而不是 6。不知道为什么。尽管如此，我仍然需要一个（正确）工作的 Fortran 2008 实现来继续前进。
编辑 - 这是可以编译但无法正常运行的 fortran 代码
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
这是一个有效的示例，其用户定义函数的接口取自 MPI 标准。乍一看，您所拥有的似乎是旧界面所需的；它肯定不符合标准所说的。
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$