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       program main
   7       implicit none
   8       include 'mpif.h'
   9       integer inbuf(2), outbuf(2)
  10       integer ans, rank, size, comm
  11       integer errs, ierr
  12       integer sumop
  13       external uop
  14
  15       errs = 0
  16
  17       call mtest_init( ierr )
  18 C
  19 C A simple test of exscan
  20       comm = MPI_COMM_WORLD
  21
  22       call mpi_comm_rank( comm, rank, ierr )
  23       call mpi_comm_size( comm, size, ierr )
  24
  25       inbuf(1) = rank
  26       inbuf(2) = -rank
  27       call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, MPI_SUM, comm,
  28      &                 ierr )
  29 C this process has the sum of i from 0 to rank-1, which is
  30 C (rank)(rank-1)/2 and -i
  31       ans = (rank * (rank - 1))/2
  32       if (rank .gt. 0) then
  33          if (outbuf(1) .ne. ans) then
  34             errs = errs + 1
  35             print *, rank, ' Expected ', ans, ' got ', outbuf(1)
  36          endif
  37          if (outbuf(2) .ne. -ans) then
  38             errs = errs + 1
  39             print *, rank, ' Expected ', -ans, ' got ', outbuf(1)
  40          endif
  41       endif
  42 C
  43 C Try a user-defined operation
  44 C
  45       call mpi_op_create( uop, .true., sumop, ierr )
  46       inbuf(1) = rank
  47       inbuf(2) = -rank
  48       call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,
  49      &                 ierr )
  50 C this process has the sum of i from 0 to rank-1, which is
  51 C (rank)(rank-1)/2 and -i
  52       ans = (rank * (rank - 1))/2
  53       if (rank .gt. 0) then
  54          if (outbuf(1) .ne. ans) then
  55             errs = errs + 1
  56             print *, rank, ' sumop: Expected ', ans, ' got ', outbuf(1)
  57          endif
  58          if (outbuf(2) .ne. -ans) then
  59             errs = errs + 1
  60             print *, rank, ' sumop: Expected ', -ans, ' got ', outbuf(1)
  61          endif
  62       endif
  63       call mpi_op_free( sumop, ierr )
  64
  65 C
  66 C Try a user-defined operation (and don't claim it is commutative)
  67 C
  68       call mpi_op_create( uop, .false., sumop, ierr )
  69       inbuf(1) = rank
  70       inbuf(2) = -rank
  71       call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,
  72      &                 ierr )
  73 C this process has the sum of i from 0 to rank-1, which is
  74 C (rank)(rank-1)/2 and -i
  75       ans = (rank * (rank - 1))/2
  76       if (rank .gt. 0) then
  77          if (outbuf(1) .ne. ans) then
  78             errs = errs + 1
  79             print *, rank, ' sumop2: Expected ', ans, ' got ', outbuf(1)
  80          endif
  81          if (outbuf(2) .ne. -ans) then
  82             errs = errs + 1
  83             print *, rank, ' sumop2: Expected ', -ans, ' got ',outbuf(1)
  84          endif
  85       endif
  86       call mpi_op_free( sumop, ierr )
  87
  88       call mtest_finalize( errs )
  89       call mpi_finalize( ierr )
  90       end
  91 C
  92       subroutine uop( cin, cout, count, datatype )
  93       implicit none
  94       include 'mpif.h'
  95       integer cin(*), cout(*)
  96       integer count, datatype
  97       integer i
  98
  99       if (.false.) then
 100          if (datatype .ne. MPI_INTEGER) then
 101             write(6,*) 'Invalid datatype passed to user_op()'
 102             return
 103          endif
 104       endif
 105
 106       do i=1, count
 107          cout(i) = cin(i) + cout(i)
 108       enddo
 109       end