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

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C (C) 2005 by Argonne National Laboratory.
   4 C     See COPYRIGHT in top-level directory.
   5 C
   6 C This is a simple test that Fortran support the MPI_IN_PLACE value
   7 C
   8        program main
   9        implicit none
  10        include 'mpif.h'
  11        integer ierr, errs
  12        integer comm, root
  13        integer rank, size
  14        integer i
  15        integer MAX_SIZE
  16        parameter (MAX_SIZE=1024)
  17        integer rbuf(MAX_SIZE), rdispls(MAX_SIZE), rcount(MAX_SIZE),
  18      $      sbuf(MAX_SIZE)
  19
  20        errs = 0
  21        call mtest_init( ierr )
  22
  23        comm = MPI_COMM_WORLD
  24        call mpi_comm_rank( comm, rank, ierr )
  25        call mpi_comm_size( comm, size, ierr )
  26
  27        root = 0
  28 C Gather with inplace
  29        do i=1,size
  30           rbuf(i) = - i
  31        enddo
  32        rbuf(1+root) = root
  33        if (rank .eq. root) then
  34           call mpi_gather( MPI_IN_PLACE, 1, MPI_INTEGER, rbuf, 1,
  35      $         MPI_INTEGER, root, comm, ierr )
  36           do i=1,size
  37              if (rbuf(i) .ne. i-1) then
  38                 errs = errs + 1
  39                 print *, '[',rank,'] rbuf(', i, ') = ', rbuf(i),
  40      $                   ' in gather'
  41              endif
  42           enddo
  43        else
  44           call mpi_gather( rank, 1, MPI_INTEGER, rbuf, 1, MPI_INTEGER,
  45      $         root, comm, ierr )
  46        endif
  47
  48 C Gatherv with inplace
  49        do i=1,size
  50           rbuf(i) = - i
  51           rcount(i) = 1
  52           rdispls(i) = i-1
  53        enddo
  54        rbuf(1+root) = root
  55        if (rank .eq. root) then
  56           call mpi_gatherv( MPI_IN_PLACE, 1, MPI_INTEGER, rbuf, rcount,
  57      $         rdispls, MPI_INTEGER, root, comm, ierr )
  58           do i=1,size
  59              if (rbuf(i) .ne. i-1) then
  60                 errs = errs + 1
  61                 print *, '[', rank, '] rbuf(', i, ') = ', rbuf(i),
  62      $                ' in gatherv'
  63              endif
  64           enddo
  65        else
  66           call mpi_gatherv( rank, 1, MPI_INTEGER, rbuf, rcount, rdispls,
  67      $         MPI_INTEGER, root, comm, ierr )
  68        endif
  69
  70 C Scatter with inplace
  71        do i=1,size
  72           sbuf(i) = i
  73        enddo
  74        rbuf(1) = -1
  75        if (rank .eq. root) then
  76           call mpi_scatter( sbuf, 1, MPI_INTEGER, MPI_IN_PLACE, 1,
  77      $         MPI_INTEGER, root, comm, ierr )
  78        else
  79           call mpi_scatter( sbuf, 1, MPI_INTEGER, rbuf, 1,
  80      $         MPI_INTEGER, root, comm, ierr )
  81           if (rbuf(1) .ne. rank+1) then
  82              errs = errs + 1
  83              print *, '[', rank, '] rbuf  = ', rbuf(1),
  84      $            ' in scatter'
  85           endif
  86        endif
  87
  88        call mtest_finalize( errs )
  89        call mpi_finalize( ierr )
  90
  91        end