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

   1 ! This file created from test/mpi/f77/coll/vw_inplacef.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 ! (C) 2012 by Argonne National Laboratory.
   5 !     See COPYRIGHT in top-level directory.
   6 !
   7 ! A simple test for Fortran support of the MPI_IN_PLACE value in Alltoall[vw].
   8 !
   9        program main
  10        use mpi
  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 ierr, errs
  17        integer comm, root
  18        integer rank, size
  19        integer iexpected, igot
  20        integer i, j
  21
  22        errs = 0
  23        call mtest_init( ierr )
  24
  25        comm = MPI_COMM_WORLD
  26        call mpi_comm_rank( comm, rank, ierr )
  27        call mpi_comm_size( comm, size, ierr )
  28        call mpi_type_size( MPI_INTEGER, SIZEOFINT, ierr )
  29
  30        if (size .gt. MAX_SIZE) then
  31           print *, ' At most ', MAX_SIZE, ' processes allowed'
  32           call mpi_abort( MPI_COMM_WORLD, 1, ierr )
  33        endif
  34 !
  35        do i=1,MAX_SIZE
  36            rbuf(i) = -1
  37        enddo
  38        do i=1,size
  39           rbuf(i) = (i-1) * size + rank
  40        enddo
  41        call mpi_alltoall( MPI_IN_PLACE, -1, MPI_DATATYPE_NULL, &
  42       &      rbuf, 1, MPI_INTEGER, comm, ierr )
  43        do i=1,size
  44           if (rbuf(i) .ne. (rank*size + i - 1)) then
  45              errs = errs + 1
  46              print *, '[', rank, '] rbuf(', i, ') = ', rbuf(i), &
  47       &             ', should be', rank * size + i - 1
  48           endif
  49        enddo
  50
  51        do i=1,MAX_SIZE
  52            rbuf(i) = -1
  53        enddo
  54        do i=1,size
  55            rcounts(i) = (i-1) + rank
  56            rdispls(i) = (i-1) * (2*size)
  57            do j=0,rcounts(i)-1
  58                rbuf(rdispls(i)+j+1) = 100 * rank + 10 * (i-1) + j
  59            enddo
  60        enddo
  61        call mpi_alltoallv( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL, &
  62       &                     rbuf, rcounts, rdispls, MPI_INTEGER, &
  63       &                     comm, ierr )
  64        do i=1,size
  65            do j=0,rcounts(i)-1
  66                iexpected = 100 * (i-1) + 10 * rank + j
  67                igot      = rbuf(rdispls(i)+j+1)
  68                if ( igot .ne. iexpected ) then
  69                    errs = errs + 1
  70                    print *, '[', rank, '] ALLTOALLV got ', igot, &
  71       &                   ',but expected ', iexpected, &
  72       &                   ' for block=', i-1, ' element=', j
  73                endif
  74            enddo
  75        enddo
  76
  77        do i=1,MAX_SIZE
  78            rbuf(i) = -1
  79        enddo
  80 !          Alltoallw's displs[] are in bytes not in type extents.
  81        do i=1,size
  82            rcounts(i) = (i-1) + rank
  83            rdispls(i) = (i-1) * (2*size) * SIZEOFINT
  84            rtypes(i)  = MPI_INTEGER
  85            do j=0,rcounts(i)-1
  86                rbuf(rdispls(i)/SIZEOFINT+j+1) = 100 * rank &
  87       &                                        + 10 * (i-1) + j
  88            enddo
  89        enddo
  90        call mpi_alltoallw( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL, &
  91       &                     rbuf, rcounts, rdispls, rtypes, &
  92       &                     comm, ierr )
  93        do i=1,size
  94            do j=0,rcounts(i)-1
  95                iexpected = 100 * (i-1) + 10 * rank + j
  96                igot      = rbuf(rdispls(i)/SIZEOFINT+j+1)
  97                if ( igot .ne. iexpected ) then
  98                    errs = errs + 1
  99                    print *, '[', rank, '] ALLTOALLW got ', igot, &
 100       &                   ',but expected ', iexpected, &
 101       &                   ' for block=', i-1, ' element=', j
 102                endif
 103            enddo
 104        enddo
 105
 106        call mtest_finalize( errs )
 107        call mpi_finalize( ierr )
 108
 109        end