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