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

   1 ! -*- Mode: Fortran; -*-
   2 !
   3 !  (C) 2003 by Argonne National Laboratory.
   4 !      See COPYRIGHT in top-level directory.
   5 !
   6 ! This test contributed by Kim McMahon, Cray
   7 !
   8       program main
   9       implicit none
  10       use mpi
  11
  12       integer ierr, i, j, type, count,errs
  13       parameter (count = 4)
  14       integer rank, size, xfersize
  15       integer status(MPI_STATUS_SIZE)
  16       integer blocklens(count), displs(count)
  17       double precision,dimension(:,:),allocatable :: sndbuf, rcvbuf
  18       logical verbose
  19
  20       verbose = .false.
  21       call mtest_init ( ierr )
  22       call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
  23       call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
  24       if (size .lt. 2) then
  25          print *, "Must have at least 2 processes"
  26          call MPI_Abort( 1, MPI_COMM_WORLD, ierr )
  27       endif
  28
  29       errs = 0
  30       allocate(sndbuf(7,100))
  31       allocate(rcvbuf(7,100))
  32
  33       do j=1,100
  34         do i=1,7
  35            sndbuf(i,j) = (i+j) * 1.0
  36          enddo
  37       enddo
  38
  39       do i=1,count
  40          blocklens(i) = 7
  41       enddo
  42
  43 ! bug occurs when first two displacements are 0
  44       displs(1) = 0
  45       displs(2) = 0
  46       displs(3) = 10
  47       displs(4) = 10
  48
  49       call mpi_type_indexed( count, blocklens, displs*blocklens(1),  &
  50       &                         MPI_DOUBLE_PRECISION, type, ierr )
  51
  52       call mpi_type_commit( type, ierr )
  53
  54 ! send using this new type
  55
  56       if (rank .eq. 0) then
  57
  58           call mpi_send( sndbuf(1,1), 1, type, 1, 0, MPI_COMM_WORLD,ierr )
  59
  60       else if (rank .eq. 1) then
  61
  62           xfersize=count * blocklens(1)
  63           call mpi_recv( rcvbuf(1,1), xfersize, MPI_DOUBLE_PRECISION, 0, 0, &
  64            &   MPI_COMM_WORLD,status, ierr )
  65
  66
  67 ! Values that should be sent
  68
  69         if (verbose) then
  70 !       displacement = 0
  71             j=1
  72             do i=1, 7
  73                print*,'sndbuf(',i,j,') = ',sndbuf(i,j)
  74             enddo
  75
  76 !       displacement = 10
  77             j=11
  78             do i=1,7
  79                print*,'sndbuf(',i,j,') = ',sndbuf(i,j)
  80             enddo
  81             print*,' '
  82
  83 ! Values received
  84             do j=1,count
  85                 do i=1,7
  86                     print*,'rcvbuf(',i,j,') = ',rcvbuf(i,j)
  87                 enddo
  88             enddo
  89         endif
  90
  91 ! Error checking
  92         do j=1,2
  93            do i=1,7
  94              if (rcvbuf(i,j) .ne. sndbuf(i,1)) then
  95                 print*,'ERROR in rcvbuf(',i,j,')'
  96                 print*,'Received ', rcvbuf(i,j),' expected ',sndbuf(i,11)
  97                 errs = errs+1
  98              endif
  99            enddo
 100         enddo
 101
 102         do j=3,4
 103            do i=1,7
 104               if (rcvbuf(i,j) .ne. sndbuf(i,11)) then
 105                 print*,'ERROR in rcvbuf(',i,j,')'
 106                 print*,'Received ', rcvbuf(i,j),' expected ',sndbuf(i,11)
 107                 errs = errs+1
 108               endif
 109            enddo
 110         enddo
 111       endif
 112 !
 113       call mpi_type_free( type, ierr )
 114       call mtest_finalize( errs )
 115       call mpi_finalize( ierr )
 116
 117       end