1C 2C Copyright (C) by Argonne National Laboratory 3C See COPYRIGHT in top-level directory 4C 5 6 subroutine uop( cin, cout, count, datatype ) 7 implicit none 8 include 'mpif.h' 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 22C 23C Test of reduce scatter. 24C 25C Each processor contributes its rank + the index to the reduction, 26C then receives the ith sum 27C 28C Can be called with any number of processors. 29C 30 31 program main 32 implicit none 33 include 'mpif.h' 34 integer errs, ierr, toterr 35 integer maxsize 36 parameter (maxsize=1024) 37 integer sendbuf(maxsize), recvbuf, recvcounts(maxsize) 38 integer size, rank, i, sumval 39 integer comm, sumop 40 external uop 41 42 errs = 0 43 44 call mtest_init( ierr ) 45 46 comm = MPI_COMM_WORLD 47 48 call mpi_comm_size( comm, size, ierr ) 49 call mpi_comm_rank( comm, rank, ierr ) 50 51 if (size .gt. maxsize) then 52 endif 53 do i=1, size 54 sendbuf(i) = rank + i - 1 55 recvcounts(i) = 1 56 enddo 57 58 call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts, 59 & MPI_INTEGER, MPI_SUM, comm, ierr ) 60 61 sumval = size * rank + ((size - 1) * size)/2 62C recvbuf should be size * (rank + i) 63 if (recvbuf .ne. sumval) then 64 errs = errs + 1 65 print *, "Did not get expected value for reduce scatter" 66 print *, rank, " Got ", recvbuf, " expected ", sumval 67 endif 68 69 call mpi_op_create( uop, .true., sumop, ierr ) 70 call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts, 71 & MPI_INTEGER, sumop, comm, ierr ) 72 73 sumval = size * rank + ((size - 1) * size)/2 74C recvbuf should be size * (rank + i) 75 if (recvbuf .ne. sumval) then 76 errs = errs + 1 77 print *, "sumop: Did not get expected value for reduce scatter" 78 print *, rank, " Got ", recvbuf, " expected ", sumval 79 endif 80 call mpi_op_free( sumop, ierr ) 81 82 call mtest_finalize( errs ) 83 84 end 85