Open MPI logo

Open MPI User's Mailing List Archives

  |   Home   |   Support   |   FAQ   |   all Open MPI User's mailing list

From: Michael Kluskens (mkluskens_at_[hidden])
Date: 2006-03-20 18:18:47


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