R + Snow + Fortran + MPI 崩溃

Question

这是my previous question 的后续行动。

我创建了一个使用 MPI Fortran 模块的 R 包。这是模块：

Module Fortranpi
USE MPI
IMPLICIT NONE
contains
subroutine dboard(darts, dartsscore)
  integer, intent(in)                    :: darts
  double precision, intent(out)          :: dartsscore
  double precision                       :: x_coord, y_coord
  integer                                :: score, n

score = 0
do n = 1, darts
  call random_number(x_coord)
  call random_number(y_coord)

  if ((x_coord**2 + y_coord**2) <= 1.0d0) then
  score = score + 1
  end if
end do

dartsscore = 4.0d0*score/darts

end subroutine dboard

subroutine pi(avepi, DARTS, ROUNDS) bind(C, name="pi_")
  use, intrinsic                         :: iso_c_binding, only : c_double, c_int
  real(c_double), intent(out)            ::  avepi
  integer(c_int), intent(in)             ::  DARTS, ROUNDS
  integer                                ::  MASTER, rank, i, n
  integer, allocatable                   ::  seed(:)
  double precision                       ::  pi_est, homepi, pirecv, pisum

! we set it to zero in the sequential run
rank = 0
! initialize the random number generator
! we make sure the seed is different for each task
call random_seed()
call random_seed(size = n)
allocate(seed(n))
seed = 12 + rank*11
call random_seed(put=seed(1:n))
deallocate(seed)

avepi = 0
do i = 0, ROUNDS-1
  call dboard(darts, pi_est)
  ! calculate the average value of pi over all iterations
  avepi = ((avepi*i) + pi_est)/(i + 1)
end do
end subroutine pi


subroutine MPIpi(avepi, DARTS, ROUNDS) bind(C, name="pi2_")
use, intrinsic                         :: iso_c_binding, only : c_double, c_int
real(c_double), intent(out)            :: avepi
integer(c_int), intent(in)             :: DARTS, ROUNDS
integer                                :: i, n, mynpts, ierr, numprocs, proc_num
integer, allocatable                   :: seed(:)
double precision                       :: pi_est, y, sumpi

  call mpi_init(ierr)
  call mpi_comm_size(MPI_COMM_WORLD, numprocs, ierr)
  call mpi_comm_rank(MPI_COMM_WORLD, proc_num, ierr)

  if (numprocs .eq. 0) then
    mynpts = ROUNDS - (numprocs-1)*(ROUNDS/numprocs)
  else
    mynpts = ROUNDS/numprocs
  endif

  ! initialize the random number generator
  ! we make sure the seed is different for each task
  call random_seed()
  call random_seed(size = n)
  allocate(seed(n))
  seed = 12 + proc_num*11
  call random_seed(put=seed(1:n))
  deallocate(seed)

  y=0.0d0
    do i = 1, mynpts
    call dboard(darts, pi_est)
    y = y + pi_est
  end do

  call mpi_reduce(y, sumpi, 1, mpi_double_precision, mpi_sum, 0, &
                  mpi_comm_world, ierr)
  if (proc_num==0) avepi = sumpi/ROUNDS
  call mpi_finalize(ierr)
end subroutine MPIpi

end module Fortranpi

这是 R 函数：

#'@export
FMPIpi <- function(DARTS, ROUNDS) {
  retvals <- .Fortran("pi2", avepi = as.numeric(1), DARTS =  as.integer(DARTS), ROUNDS =  as.integer(ROUNDS))
  return(retvals$avepi)
}

我能够在 Rstudio 中编译和加载包。

现在我正在尝试用这个 R 代码调用我的函数：

library(snow)
cl <- makeCluster(2, type = "MPI")
clusterEvalQ(cl, MyPi::FMPIpi(DARTS = 5000, ROUNDS = 100))
stopCluster(cl)

但是当我尝试运行它时，Rstudio 崩溃了。我做错了什么？

---

这是一个更简单的例子（也不起作用）

我创建了一个包HelloFMPI。 NAMESPACE 有这个

  useDynLib(HelloFMPI)
  exportPattern("^[[:alpha:]]+")

test.f90:

subroutine test(id, ierr)
use mpi
implicit none
integer*4 id, ierr
call MPI_Comm_rank(MPI_COMM_WORLD, id, ierr)
end subroutine test

和hello.R：

hello <- function() {
  r <- .Fortran("test", as.integer(0), as.integer(0))
  return(r)
}

我可以使用 Rstudio 构建和加载包。当我运行这段代码时：

library(HelloFMPI)
library(snow)
cl <- makeCluster(2, type = "MPI")
clusterEvalQ(cl, HelloFMPI::hello())
stopCluster(cl)

Rstudio 崩溃

Answer 1

在

library(snow)
cl <- makeCluster(2, type = "MPI")
clusterEvalQ(cl, MyPi::FMPIpi(DARTS = 5000, ROUNDS = 100))
stopCluster(cl)

你忘记加载包MyPi。

编辑：根据您的编辑，请允许我补充一点，我从在 RStudio 中运行 (Open)MPI（甚至是 OpenMP）代码，因为它的 GUI 线程它。对于并行工作，从命令行开始。如果您期望 MPI 上下文，请使用 mpirun 或 orterun。