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