teshsuite/smpi/mpich3-test/f77/coll/alltoallwf.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 ierr, errs
  10       integer i, intsize, ans, size, rank, color, comm, newcomm
  11       integer maxSize
  12       parameter (maxSize=32)
  13       integer scounts(maxSize), sdispls(maxSize), stypes(maxSize)
  14       integer rcounts(maxSize), rdispls(maxSize), rtypes(maxSize)
  15       integer sbuf(maxSize), rbuf(maxSize)
  16       errs = 0
  17
  18       call mtest_init( ierr )
  19
  20       call mpi_type_size( MPI_INTEGER, intsize, ierr )
  21
  22 C Get a comm
  23       call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
  24       call mpi_comm_size( comm, size, ierr )
  25       if (size .gt. maxSize) then
  26          call mpi_comm_rank( comm, rank, ierr )
  27          color = 1
  28          if (rank .lt. maxSize) color = 0
  29          call mpi_comm_split( comm, color, rank, newcomm, ierr )
  30          call mpi_comm_free( comm, ierr )
  31          comm = newcomm
  32          call mpi_comm_size( comm, size, ierr )
  33       endif
  34       call mpi_comm_rank( comm, rank, ierr )
  35
  36       if (size .le. maxSize) then
  37 C Initialize the data.  Just use this as an all to all
  38          do i=1, size
  39             scounts(i) = 1
  40             sdispls(i) = (i-1)*intsize
  41             stypes(i)  = MPI_INTEGER
  42             sbuf(i) = rank * size + i
  43             rcounts(i) = 1
  44             rdispls(i) = (i-1)*intsize
  45             rtypes(i)  = MPI_INTEGER
  46             rbuf(i) = -1
  47          enddo
  48          call mpi_alltoallw( sbuf, scounts, sdispls, stypes,
  49      &        rbuf, rcounts, rdispls, rtypes, comm, ierr )
  50 C
  51 C check rbuf(i) = data from the ith location of the ith send buf, or
  52 C       rbuf(i) = (i-1) * size + i
  53          do i=1, size
  54             ans = (i-1) * size + rank + 1
  55             if (rbuf(i) .ne. ans) then
  56                errs = errs + 1
  57                print *, rank, ' rbuf(', i, ') = ', rbuf(i),
  58      &               ' expected ', ans
  59             endif
  60          enddo
  61       endif
  62       call mpi_comm_free( comm, ierr )
  63
  64       call mtest_finalize( errs )
  65       call mpi_finalize( ierr )
  66       end
  67