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

   1 ! This file created from test/mpi/f77/coll/inplacef.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 ! (C) 2005 by Argonne National Laboratory.
   5 !     See COPYRIGHT in top-level directory.
   6 !
   7 ! This is a simple test that Fortran support the MPI_IN_PLACE value
   8 !
   9        program main
  10        use mpi
  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 ! 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 ! 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 ! 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