The sample code at the end of this message demonstrates issues with
multiple versions of OpenMPI.
OpenMPI 1.0.2a10 compiles the code but crashes because of the
interface issues previously discussed. This is both using " USE MPI
" and " include 'mpif.h' "
OpenMPI 1.1a1r9336 generates the following output (generated on OS X
with g95, but same errors previously documented on Debian Linux with
pgif90 version 6.1):
>spawn
How many processes total?
2
alpha 0 of 1
master receiving
alpha 0 receiving 17 from master
alpha 0 sending -1 0
answer= -1 0 from alpha 0 0
[x:14559] [0,0,0] ORTE_ERROR_LOG: GPR data corruption in file base/
soh_base_get_proc_soh.c at line 100
[x:14559] [0,0,0] ORTE_ERROR_LOG: GPR data corruption in file base/
oob_base_xcast.c at line 108
[x:14559] [0,0,0] ORTE_ERROR_LOG: GPR data corruption in file base/
rmgr_base_stage_gate.c at line 276
[x:14559] [0,0,0] ORTE_ERROR_LOG: GPR data corruption in file base/
soh_base_get_proc_soh.c at line 100
[x:14559] [0,0,0] ORTE_ERROR_LOG: GPR data corruption in file base/
oob_base_xcast.c at line 108
[x:14559] [0,0,0] ORTE_ERROR_LOG: GPR data corruption in file base/
rmgr_base_stage_gate.c at line 276
Michael
---- spawn.f90 ---
program main
USE MPI
implicit none
! include 'mpif.h'
integer :: ierr,size,rank,child
integer (kind=MPI_ADDRESS_KIND) :: universe_size
integer :: status(MPI_STATUS_SIZE)
logical :: flag
integer :: ans(0:2),btest
integer :: k, subprocesses
real :: ts(4)
call MPI_INIT(ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD,size,ierr)
if ( size /= 1 ) then
if ( rank == 0 ) then
write(*,*) 'Only one master process permitted'
write(*,*) 'Terminating all but root process'
else
call MPI_FINALIZE(ierr)
stop
end if
end if
call MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_UNIVERSE_SIZE,
universe_size, flag,ierr)
if ( .not. flag ) then
write(*,*) 'This MPI does not support UNIVERSE_SIZE.'
write(*,*) 'How many processes total?'
read(*,*) universe_size
else if ( universe_size < 2 ) then
write(*,*) 'How many processes total?'
read(*,*) universe_size
end if
subprocesses = universe_size-1
call MPI_Comm_spawn('subprocess', MPI_ARGV_NULL, subprocesses,
MPI_INFO_NULL, 0, &
MPI_COMM_WORLD, child, MPI_ERRCODES_IGNORE, ierr )
btest = 17
call MPI_BCAST( btest, 1, MPI_INTEGER, MPI_ROOT, child, ierr )
call MPI_BCAST( ts,4 ,MPI_REAL ,MPI_ROOT,child,ierr)
do k = 1, universe_size-1
write(*,*) 'master receiving'
ans = 0
call MPI_RECV( ans, 2, MPI_INTEGER, MPI_ANY_SOURCE, MPI_ANY_TAG,
child, status, ierr )
write(*,*) 'answer=',ans(0:1),' from alpha',status
(MPI_SOURCE),status(MPI_TAG)
end do
call MPI_COMM_FREE(child,ierr)
call MPI_FINALIZE(ierr)
end
--- subprocess.f90 ----
program alpha
USE MPI
implicit none
! include 'mpif.h'
integer :: ierr,size,rank,parent,rsize
integer :: ans(0:2), btest
real :: ts(4)
call MPI_INIT(ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD,size,ierr)
write(*,*) 'alpha',rank,' of ',size
call MPI_Comm_get_parent(parent,ierr)
call MPI_BCAST( btest, 1, MPI_INTEGER, 0, parent, ierr )
call MPI_BCAST(ts,4,MPI_REAL,0,parent,ierr)
write(*,*) 'alpha',rank,'receiving',btest,'from master'
ans(0) = rank-1
ans(1) = rank
ans(2) = rank+1
write(*,*) 'alpha',rank,' sending',ans(0:1)
call MPI_SSEND( ans, 2, MPI_INTEGER, 0, rank, parent, ierr)
call MPI_FINALIZE(ierr)
end program alpha
