fmpi_sane.f

Go to the documentation of this file.

      program fmpi_sane
*
*     This program checks to make sure that you can run a basic program
*     on your machine using the Fortran77 interface to MPI.
*     Can increase parameter wastesz, if you think size of executable
*     is causing launching problem.
*
      include 'mpif.h'
      integer nproc, wastesz
      parameter(nproc = 4)
      parameter(wastesz = 100)
      integer i, iam, np, ierr
      integer mcom, wgrp, mgrp
      integer irank(nproc), stat(mpi_status_size)
      double precision wastespc(wastesz)
 
      call mpi_init(ierr)
      call mpi_comm_size(mpi_comm_world, np, ierr)
      if (np .lt. nproc) then
         print*,'Not enough processes to run sanity check'
         call mpi_abort(mpi_comm_world, -1, ierr)
      end if
*
*     Access all of WasteSpc
*
      do 10 i = 1, wastesz
         wastespc(i) = 0.0d0
10    continue
*
*     Form context with NPROC members
*
      do 20 i = 1, nproc
         irank(i) = i - 1
20    continue
      call mpi_comm_group(mpi_comm_world, wgrp, ierr)
      call mpi_group_incl(wgrp, nproc, irank, mgrp, ierr)
      call mpi_comm_create(mpi_comm_world, mgrp, mcom, ierr)
      call mpi_group_free(mgrp, ierr)
*
*     Everyone in new communicator sends a message to his neighbor
*
      if (mcom .ne. mpi_comm_null) then
         call mpi_comm_rank(mcom, iam, ierr)
*
*        Odd nodes receive first, so we don't hang if MPI_Send is
*        globally blocking
*
         if (mod(iam, 2) .ne. 0) then
            call mpi_recv(i, 1, mpi_integer, mod(nproc+iam-1, nproc), 
     &                    0, mcom, stat, ierr)
            call mpi_send(iam, 1, mpi_integer, mod(iam+1, nproc), 
     &                    0, mcom, ierr)
         else
            call mpi_send(iam, 1, mpi_integer, mod(iam+1, nproc), 
     &                    0, mcom, ierr)
            call mpi_recv(i, 1, mpi_integer, mod(nproc+iam-1, nproc), 
     &                    0, mcom, stat, ierr)
         end if
*
*        Make sure we've received the right information
*
         if (i .ne. mod(nproc+iam-1, nproc)) then
            print*,'Communication does not seem to work properly!!'
            call mpi_abort(mpi_comm_world, -1, ierr)
         end if
      end if
 
      print*,iam,' F77 MPI sanity test passed.'
      call mpi_finalize(ierr)
 
      stop
      end