teshsuite/smpi/mpich3-test/f77/coll/red_scat_blockf.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C (C) 2012 by Argonne National Laboratory.
   4 C     See COPYRIGHT in top-level directory.
   5 C
   6 C A simple test for Fortran support of Reduce_scatter_block
   7 C with or withoutMPI_IN_PLACE.
   8 C
   9        program main
  10        implicit none
  11        include 'mpif.h'
  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 C 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