teshsuite/smpi/mpich3-test/f77/datatype/typesubf.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2003 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   6       program main
   7       implicit none
   8       include 'mpif.h'
   9       integer errs, ierr
  10       integer maxn, maxm
  11       parameter (maxn=10,maxm=15)
  12       integer fullsizes(2), subsizes(2), starts(2)
  13       integer fullarr(maxn,maxm),subarr(maxn-3,maxm-4)
  14       integer i,j, ssize
  15       integer newtype, size, rank, ans
  16
  17       errs = 0
  18       call mtest_init( ierr )
  19       call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
  20       call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
  21 C
  22 C Create a Fortran-style subarray
  23       fullsizes(1) = maxn
  24       fullsizes(2) = maxm
  25       subsizes(1)  = maxn - 3
  26       subsizes(2)  = maxm - 4
  27 C starts are from zero, even in Fortran
  28       starts(1)    = 1
  29       starts(2)    = 2
  30 C In Fortran 90 notation, the original array is
  31 C    integer a(maxn,maxm)
  32 C and the subarray is
  33 C    a(1+1:(maxn-3) +(1+1)-1,2+1:(maxm-4)+(2+1)-1)
  34 C i.e., a (start:(len + start - 1),...)
  35       call mpi_type_create_subarray( 2, fullsizes, subsizes, starts,
  36      &         MPI_ORDER_FORTRAN, MPI_INTEGER, newtype, ierr )
  37       call mpi_type_commit( newtype, ierr )
  38 C
  39 C Prefill the array
  40       do j=1, maxm
  41          do i=1, maxn
  42             fullarr(i,j) = (i-1) + (j-1) * maxn
  43          enddo
  44       enddo
  45       do j=1, subsizes(2)
  46          do i=1, subsizes(1)
  47             subarr(i,j) = -1
  48          enddo
  49       enddo
  50       ssize = subsizes(1)*subsizes(2)
  51       call mpi_sendrecv( fullarr, 1, newtype, rank, 0,
  52      &                   subarr, ssize, MPI_INTEGER, rank, 0,
  53      &                   MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr )
  54 C
  55 C Check the data
  56       do j=1, subsizes(2)
  57          do i=1, subsizes(1)
  58             ans = (i+starts(1)-1) + (j+starts(2)-1) * maxn
  59             if (subarr(i,j) .ne. ans) then
  60                errs = errs + 1
  61                if (errs .le. 10) then
  62                   print *, rank, 'subarr(',i,',',j,') = ', subarr(i,j)
  63                endif
  64             endif
  65          enddo
  66       enddo
  67
  68       call mpi_type_free( newtype, ierr )
  69
  70       call mtest_finalize( errs )
  71       call mpi_finalize( ierr )
  72
  73       end