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

   1 ! This file created from test/mpi/f77/coll/redscatf.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 !  (C) 2011 by Argonne National Laboratory.
   5 !      See COPYRIGHT in top-level directory.
   6 !
   7       subroutine uop( cin, cout, count, datatype )
   8       use mpi
   9       integer cin(*), cout(*)
  10       integer count, datatype
  11       integer i
  12
  13       if (.false.) then
  14          if (datatype .ne. MPI_INTEGER) then
  15             write(6,*) 'Invalid datatype ',datatype,' passed to user_op()'
  16             return
  17          endif
  18       endif
  19
  20       do i=1, count
  21          cout(i) = cin(i) + cout(i)
  22       enddo
  23       end
  24 !
  25 ! Test of reduce scatter.
  26 !
  27 ! Each processor contributes its rank + the index to the reduction,
  28 ! then receives the ith sum
  29 !
  30 ! Can be called with any number of processors.
  31 !
  32
  33       program main
  34       use mpi
  35       integer errs, ierr
  36       integer maxsize
  37       parameter (maxsize=1024)
  38       integer recvbuf
  39       integer size, rank, i, sumval
  40       integer comm, sumop
  41       external uop
  42       integer status
  43       integer, dimension(:),allocatable :: sendbuf,recvcounts
  44       ALLOCATE(sendbuf(maxsize), STAT=status)
  45       ALLOCATE(recvcounts(maxsize), STAT=status)
  46       errs = 0
  47
  48       call mtest_init( ierr )
  49
  50       comm = MPI_COMM_WORLD
  51
  52       call mpi_comm_size( comm, size, ierr )
  53       call mpi_comm_rank( comm, rank, ierr )
  54
  55       if (size .gt. maxsize) then
  56       endif
  57       do i=1, size
  58          sendbuf(i) = rank + i - 1
  59          recvcounts(i) = 1
  60       enddo
  61
  62       call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts,  &
  63       &     MPI_INTEGER, MPI_SUM, comm, ierr )
  64
  65       sumval = size * rank + ((size - 1) * size)/2
  66 ! recvbuf should be size * (rank + i)
  67       if (recvbuf .ne. sumval) then
  68          errs = errs + 1
  69          print *, "Did not get expected value for reduce scatter"
  70          print *, rank, " Got ", recvbuf, " expected ", sumval
  71       endif
  72
  73       call mpi_op_create( uop, .true., sumop, ierr )
  74       call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts,  &
  75       &     MPI_INTEGER, sumop, comm, ierr )
  76
  77       sumval = size * rank + ((size - 1) * size)/2
  78 ! recvbuf should be size * (rank + i)
  79       if (recvbuf .ne. sumval) then
  80          errs = errs + 1
  81          print *, "sumop: Did not get expected value for reduce scatter"
  82          print *, rank, " Got ", recvbuf, " expected ", sumval
  83       endif
  84       call mpi_op_free( sumop, ierr )
  85       DEALLOCATE(sendbuf)
  86       DEALLOCATE(recvcounts)
  87       call mtest_finalize( errs )
  88       call mpi_finalize( ierr )
  89
  90       end