teshsuite/smpi/mpich3-test/f90/datatype/hindex1f90.f90

   1 ! This file created from test/mpi/f77/datatype/hindex1f.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 !
   5 !  (C) 2011 by Argonne National Laboratory.
   6 !      See COPYRIGHT in top-level directory.
   7 !
   8       program main
   9       use mpi
  10       integer errs, ierr, intsize
  11       integer i, displs(10), counts(10), dtype
  12       integer bufsize
  13       parameter (bufsize=100)
  14       integer inbuf(bufsize), outbuf(bufsize), packbuf(bufsize)
  15       integer position, len, psize
  16 !
  17 !     Test for hindexed;
  18 !
  19       errs = 0
  20       call mtest_init( ierr )
  21
  22       call mpi_type_size( MPI_INTEGER, intsize, ierr )
  23
  24       do i=1, 10
  25          displs(i) = (10-i)*intsize
  26          counts(i) = 1
  27       enddo
  28       call mpi_type_hindexed( 10, counts, displs, MPI_INTEGER, dtype, &
  29       &     ierr )
  30       call mpi_type_commit( dtype, ierr )
  31 !
  32       call mpi_pack_size( 1, dtype, MPI_COMM_WORLD, psize, ierr )
  33       if (psize .gt. bufsize*intsize) then
  34          errs = errs + 1
  35       else
  36          do i=1,10
  37             inbuf(i)  = i
  38             outbuf(i) = -i
  39          enddo
  40          position = 0
  41          call mpi_pack( inbuf, 1, dtype, packbuf, psize, position, &
  42       &        MPI_COMM_WORLD, ierr )
  43 !
  44          len      = position
  45          position = 0
  46          call mpi_unpack( packbuf, len, position, outbuf, 10, &
  47       &        MPI_INTEGER, MPI_COMM_WORLD, ierr )
  48 !
  49          do i=1, 10
  50             if (outbuf(i) .ne. 11-i) then
  51                errs = errs + 1
  52                print *, 'outbuf(',i,')=',outbuf(i),', expected ', 10-i
  53             endif
  54          enddo
  55       endif
  56 !
  57       call mpi_type_free( dtype, ierr )
  58 !
  59       call mtest_finalize( errs )
  60       call mpi_finalize( ierr )
  61       end