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

   1 ! This file created from test/mpi/f77/coll/alltoallvf.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 !  (C) 2011 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, ans, size, rank, color, comm, newcomm
  11       integer maxSize, displ
  12       parameter (maxSize=128)
  13       integer scounts(maxSize), sdispls(maxSize), stypes(maxSize)
  14       integer rcounts(maxSize), rdispls(maxSize), rtypes(maxSize)
  15       integer sbuf(maxSize), rbuf(maxSize)
  16
  17       errs = 0
  18
  19       call mtest_init( ierr )
  20
  21 ! Get a comm
  22       call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
  23       call mpi_comm_size( comm, size, ierr )
  24       if (size .gt. maxSize) then
  25          call mpi_comm_rank( comm, rank, ierr )
  26          color = 1
  27          if (rank .lt. maxSize) color = 0
  28          call mpi_comm_split( comm, color, rank, newcomm, ierr )
  29          call mpi_comm_free( comm, ierr )
  30          comm = newcomm
  31          call mpi_comm_size( comm, size, ierr )
  32       endif
  33       call mpi_comm_rank( comm, rank, ierr )
  34 !
  35       if (size .le. maxSize) then
  36 ! Initialize the data.  Just use this as an all to all
  37 ! Use the same test as alltoallwf.c , except displacements are in units of
  38 ! integers instead of bytes
  39          do i=1, size
  40             scounts(i) = 1
  41             sdispls(i) = (i-1)
  42             stypes(i)  = MPI_INTEGER
  43             sbuf(i) = rank * size + i
  44             rcounts(i) = 1
  45             rdispls(i) = (i-1)
  46             rtypes(i)  = MPI_INTEGER
  47             rbuf(i) = -1
  48          enddo
  49          call mpi_alltoallv( sbuf, scounts, sdispls, stypes, &
  50       &        rbuf, rcounts, rdispls, rtypes, comm, ierr )
  51 !
  52 ! check rbuf(i) = data from the ith location of the ith send buf, or
  53 !       rbuf(i) = (i-1) * size + i
  54          do i=1, size
  55             ans = (i-1) * size + rank + 1
  56             if (rbuf(i) .ne. ans) then
  57                errs = errs + 1
  58                print *, rank, ' rbuf(', i, ') = ', rbuf(i),  &
  59       &               ' expected ', ans
  60             endif
  61          enddo
  62 !
  63 !     A halo-exchange example - mostly zero counts
  64 !
  65          do i=1, size
  66             scounts(i) = 0
  67             sdispls(i) = 0
  68             stypes(i)  = MPI_INTEGER
  69             sbuf(i) = -1
  70             rcounts(i) = 0
  71             rdispls(i) = 0
  72             rtypes(i)  = MPI_INTEGER
  73             rbuf(i) = -1
  74          enddo
  75
  76 !
  77 !     Note that the arrays are 1-origin
  78          displ = 0
  79          if (rank .gt. 0) then
  80             scounts(1+rank-1) = 1
  81             rcounts(1+rank-1) = 1
  82             sdispls(1+rank-1) = displ
  83             rdispls(1+rank-1) = rank - 1
  84             sbuf(1+displ)     = rank
  85             displ             = displ + 1
  86          endif
  87          scounts(1+rank)   = 1
  88          rcounts(1+rank)   = 1
  89          sdispls(1+rank)   = displ
  90          rdispls(1+rank)   = rank
  91          sbuf(1+displ)     = rank
  92          displ           = displ + 1
  93          if (rank .lt. size-1) then
  94             scounts(1+rank+1) = 1
  95             rcounts(1+rank+1) = 1
  96             sdispls(1+rank+1) = displ
  97             rdispls(1+rank+1) = rank+1
  98             sbuf(1+displ)     = rank
  99             displ             = displ + 1
 100          endif
 101
 102          call mpi_alltoallv( sbuf, scounts, sdispls, stypes, &
 103       &        rbuf, rcounts, rdispls, rtypes, comm, ierr )
 104 !
 105 !   Check the neighbor values are correctly moved
 106 !
 107          if (rank .gt. 0) then
 108             if (rbuf(1+rank-1) .ne. rank-1) then
 109                errs = errs + 1
 110                print *, rank, ' rbuf(',1+rank-1, ') = ', rbuf(1+rank-1), &
 111       &              'expected ', rank-1
 112             endif
 113          endif
 114          if (rbuf(1+rank) .ne. rank) then
 115             errs = errs + 1
 116             print *, rank, ' rbuf(', 1+rank, ') = ', rbuf(1+rank), &
 117       &           'expected ', rank
 118          endif
 119          if (rank .lt. size-1) then
 120             if (rbuf(1+rank+1) .ne. rank+1) then
 121                errs = errs + 1
 122                print *, rank, ' rbuf(', 1+rank+1, ') = ',rbuf(1+rank+1), &
 123       &              'expected ', rank+1
 124             endif
 125          endif
 126          do i=0,rank-2
 127             if (rbuf(1+i) .ne. -1) then
 128                errs = errs + 1
 129                print *, rank, ' rbuf(', 1+i, ') = ', rbuf(1+i),  &
 130       &              'expected -1'
 131             endif
 132          enddo
 133          do i=rank+2,size-1
 134             if (rbuf(1+i) .ne. -1) then
 135                errs = errs + 1
 136                print *, rank, ' rbuf(', i, ') = ', rbuf(1+i),  &
 137       &              'expected -1'
 138             endif
 139          enddo
 140       endif
 141       call mpi_comm_free( comm, ierr )
 142
 143       call mtest_finalize( errs )
 144       call mpi_finalize( ierr )
 145       end
 146