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