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

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2003 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   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 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 C
  23       program main
  24       implicit none
  25       include 'mpif.h'
  26       integer inbuf(2), outbuf(2)
  27       integer ans, rank, size, comm
  28       integer errs, ierr
  29       integer sumop
  30       external uop
  31
  32       errs = 0
  33
  34       call mtest_init( ierr )
  35 C
  36 C A simple test of exscan
  37       comm = MPI_COMM_WORLD
  38
  39       call mpi_comm_rank( comm, rank, ierr )
  40       call mpi_comm_size( comm, size, ierr )
  41
  42       inbuf(1) = rank
  43       inbuf(2) = -rank
  44       call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, MPI_SUM, comm,
  45      &                 ierr )
  46 C this process has the sum of i from 0 to rank-1, which is
  47 C (rank)(rank-1)/2 and -i
  48       ans = (rank * (rank - 1))/2
  49       if (rank .gt. 0) then
  50          if (outbuf(1) .ne. ans) then
  51             errs = errs + 1
  52             print *, rank, ' Expected ', ans, ' got ', outbuf(1)
  53          endif
  54          if (outbuf(2) .ne. -ans) then
  55             errs = errs + 1
  56             print *, rank, ' Expected ', -ans, ' got ', outbuf(1)
  57          endif
  58       endif
  59 C
  60 C Try a user-defined operation
  61 C
  62       call mpi_op_create( uop, .true., sumop, ierr )
  63       inbuf(1) = rank
  64       inbuf(2) = -rank
  65       call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,
  66      &                 ierr )
  67 C this process has the sum of i from 0 to rank-1, which is
  68 C (rank)(rank-1)/2 and -i
  69       ans = (rank * (rank - 1))/2
  70       if (rank .gt. 0) then
  71          if (outbuf(1) .ne. ans) then
  72             errs = errs + 1
  73             print *, rank, ' sumop: Expected ', ans, ' got ', outbuf(1)
  74          endif
  75          if (outbuf(2) .ne. -ans) then
  76             errs = errs + 1
  77             print *, rank, ' sumop: Expected ', -ans, ' got ', outbuf(1)
  78          endif
  79       endif
  80       call mpi_op_free( sumop, ierr )
  81
  82 C
  83 C Try a user-defined operation (and don't claim it is commutative)
  84 C
  85       call mpi_op_create( uop, .false., sumop, ierr )
  86       inbuf(1) = rank
  87       inbuf(2) = -rank
  88       call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,
  89      &                 ierr )
  90 C this process has the sum of i from 0 to rank-1, which is
  91 C (rank)(rank-1)/2 and -i
  92       ans = (rank * (rank - 1))/2
  93       if (rank .gt. 0) then
  94          if (outbuf(1) .ne. ans) then
  95             errs = errs + 1
  96             print *, rank, ' sumop2: Expected ', ans, ' got ', outbuf(1)
  97          endif
  98          if (outbuf(2) .ne. -ans) then
  99             errs = errs + 1
 100             print *, rank, ' sumop2: Expected ', -ans, ' got ',outbuf(1)
 101          endif
 102       endif
 103       call mpi_op_free( sumop, ierr )
 104
 105       call mtest_finalize( errs )
 106       call mpi_finalize( ierr )
 107       end