teshsuite/smpi/mpich3-test/f90/coll/red_scat_blockf90.f90

   1 ! This file created from test/mpi/f77/coll/red_scat_blockf.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 ! (C) 2012 by Argonne National Laboratory.
   5 !     See COPYRIGHT in top-level directory.
   6 !
   7 ! A simple test for Fortran support of Reduce_scatter_block
   8 ! with or withoutMPI_IN_PLACE.
   9 !
  10        program main
  11        use mpi
  12        integer MAX_SIZE
  13        parameter (MAX_SIZE=1024)
  14        integer sbuf(MAX_SIZE), rbuf(MAX_SIZE)
  15        integer comm, rank, size
  16        integer sumval, ierr, errs, i
  17
  18        errs = 0
  19        call mtest_init( ierr )
  20
  21        comm = MPI_COMM_WORLD
  22        call mpi_comm_rank( comm, rank, ierr )
  23        call mpi_comm_size( comm, size, ierr )
  24
  25        do i = 1, size
  26            sbuf(i) = rank + (i-1)
  27        enddo
  28
  29        call MPI_Reduce_scatter_block(sbuf, rbuf, 1, MPI_INTEGER, &
  30       &                               MPI_SUM, comm, ierr)
  31
  32        sumval = size * rank + ((size-1) * size)/2
  33        if ( rbuf(1) .ne. sumval ) then
  34            errs = errs + 1
  35            print *, 'Reduce_scatter_block does not get expected value.'
  36            print *, '[', rank, ']', 'Got ', rbuf(1), ' but expected ', &
  37       &              sumval, '.'
  38        endif
  39
  40 ! Try MPI_IN_PLACE
  41        do i = 1, size
  42            rbuf(i) = rank + (i-1)
  43        enddo
  44        call MPI_Reduce_scatter_block(MPI_IN_PLACE, rbuf, 1, MPI_INTEGER, &
  45       &                               MPI_SUM, comm, ierr)
  46        if ( rbuf(1) .ne. sumval ) then
  47            errs = errs + 1
  48            print *, 'Reduce_scatter_block does not get expected value.'
  49            print *, '[', rank, ']', 'Got ', rbuf(1), ' but expected ', &
  50       &              sumval, '.'
  51        endif
  52
  53        call mtest_finalize( errs )
  54        call mpi_finalize( ierr )
  55
  56        end