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

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C (C) 2012 by Argonne National Laboratory.
   4 C     See COPYRIGHT in top-level directory.
   5 C
   6 C A simple test for Fortran support of the MPI_IN_PLACE value in Alltoall[vw].
   7 C
   8        program main
   9        implicit none
  10        include 'mpif.h'
  11        integer SIZEOFINT
  12        integer MAX_SIZE
  13        parameter (MAX_SIZE=1024)
  14        integer rbuf(MAX_SIZE)
  15        integer rdispls(MAX_SIZE), rcounts(MAX_SIZE), rtypes(MAX_SIZE)
  16        integer comm, rank, size, req
  17        integer sumval, ierr, errs
  18        integer iexpected, igot
  19        integer i, j
  20
  21        errs = 0
  22        call mtest_init( ierr )
  23
  24        comm = MPI_COMM_WORLD
  25        call mpi_comm_rank( comm, rank, ierr )
  26        call mpi_comm_size( comm, size, ierr )
  27        call mpi_type_size( MPI_INTEGER, SIZEOFINT, ierr )
  28
  29        do i=1,MAX_SIZE
  30            rbuf(i) = -1
  31        enddo
  32        do i=1,size
  33           rbuf(i) = (i-1) * size + rank
  34        enddo
  35        call mpi_ialltoall( MPI_IN_PLACE, -1, MPI_DATATYPE_NULL,
  36      .                      rbuf, 1, MPI_INTEGER, comm, req, ierr )
  37        call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
  38        do i=1,size
  39           if (rbuf(i) .ne. (rank*size + i - 1)) then
  40              errs = errs + 1
  41              print *, '[', rank, ']: IALLTOALL rbuf(', i, ') = ',
  42      .             rbuf(i), ', should be', rank * size + i - 1
  43           endif
  44        enddo
  45
  46        do i=1,MAX_SIZE
  47            rbuf(i) = -1
  48        enddo
  49        do i=1,size
  50            rcounts(i) = i-1 + rank
  51            rdispls(i) = (i-1) * (2*size)
  52            do j=0,rcounts(i)-1
  53                rbuf(rdispls(i)+j+1) = 100 * rank + 10 * (i-1) + j
  54            enddo
  55        enddo
  56        call mpi_ialltoallv( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL,
  57      .                       rbuf, rcounts, rdispls, MPI_INTEGER,
  58      .                       comm, req, ierr )
  59        call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
  60        do i=1,size
  61            do j=0,rcounts(i)-1
  62                iexpected = 100 * (i-1) + 10 * rank + j
  63                igot      = rbuf(rdispls(i)+j+1)
  64                if ( igot .ne. iexpected ) then
  65                    errs = errs + 1
  66                    print *, '[', rank, ']: IALLTOALLV got ', igot,
  67      .                   ',but expected ', iexpected,
  68      .                   ' for block=', i-1, ' element=', j
  69                endif
  70            enddo
  71        enddo
  72
  73        do i=1,MAX_SIZE
  74            rbuf(i) = -1
  75        enddo
  76        do i=1,size
  77            rcounts(i) = i-1 + rank
  78            rdispls(i) = (i-1) * (2*size) * SIZEOFINT
  79            rtypes(i)  = MPI_INTEGER
  80            do j=0,rcounts(i)-1
  81                rbuf(rdispls(i)/SIZEOFINT+j+1) = 100 * rank
  82      .                                        + 10 * (i-1) + j
  83            enddo
  84        enddo
  85        call mpi_ialltoallw( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL,
  86      .                       rbuf, rcounts, rdispls, rtypes,
  87      .                       comm, req, ierr )
  88        call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
  89        do i=1,size
  90            do j=0,rcounts(i)-1
  91                iexpected = 100 * (i-1) + 10 * rank + j
  92                igot      = rbuf(rdispls(i)/SIZEOFINT+j+1)
  93                if ( igot .ne. iexpected ) then
  94                    errs = errs + 1
  95                    print *, '[', rank, ']: IALLTOALLW got ', igot,
  96      .                   ',but expected ', iexpected,
  97      .                   ' for block=', i-1, ' element=', j
  98                endif
  99            enddo
 100        enddo
 101
 102        do i=1,MAX_SIZE
 103            rbuf(i) = -1
 104        enddo
 105        do i = 1, size
 106            rbuf(i) = rank + (i-1)
 107        enddo
 108        call mpi_ireduce_scatter_block( MPI_IN_PLACE, rbuf, 1,
 109      .                                  MPI_INTEGER, MPI_SUM, comm,
 110      .                                  req, ierr )
 111        call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
 112
 113        sumval = size * rank + ((size-1) * size)/2
 114        if ( rbuf(1) .ne. sumval ) then
 115            errs = errs + 1
 116            print *, 'Ireduce_scatter_block does not get expected value.'
 117            print *, '[', rank, ']:', 'Got ', rbuf(1), ' but expected ',
 118      .              sumval, '.'
 119        endif
 120
 121        call mtest_finalize( errs )
 122        call mpi_finalize( ierr )
 123
 124        end