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

   1 ! This file created from test/mpi/f77/coll/alltoallwf.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 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 ! 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 ! 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 !
  51 ! check rbuf(i) = data from the ith location of the ith send buf, or
  52 !       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