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

   1 ! This file created from test/mpi/f77/coll/exscanf.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 !  (C) 2003 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 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       program main
  24       use mpi
  25       integer, dimension(:), allocatable :: inbuf, outbuf
  26       integer ans, rank, size, comm
  27       integer errs, ierr
  28       integer sumop, status
  29       external uop
  30       allocate(inbuf(2), STAT=status)
  31       allocate(outbuf(2), STAT=status)
  32       errs = 0
  33
  34       call mtest_init( ierr )
  35 !
  36 ! 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 ! this process has the sum of i from 0 to rank-1, which is
  47 ! (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 !
  60 ! Try a user-defined operation
  61 !
  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 ! this process has the sum of i from 0 to rank-1, which is
  68 ! (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 !
  83 ! Try a user-defined operation (and don't claim it is commutative)
  84 !
  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 ! this process has the sum of i from 0 to rank-1, which is
  91 ! (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       deallocate(inbuf)
 105       deallocate(outbuf)
 106       call mtest_finalize( errs )
 107       call mpi_finalize( ierr )
 108       end