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( MPI_COMM_WORLD, 1, ierr )
  27          stop
  28       endif
  29
  30       errs = 0
  31       allocate(sndbuf(7,100))
  32       allocate(rcvbuf(7,100))
  33
  34       do j=1,100
  35         do i=1,7
  36            sndbuf(i,j) = (i+j) * 1.0
  37          enddo
  38       enddo
  39
  40       do i=1,count
  41          blocklens(i) = 7
  42       enddo
  43
  44 ! bug occurs when first two displacements are 0
  45       displs(1) = 0
  46       displs(2) = 0
  47       displs(3) = 10
  48       displs(4) = 10
  49
  50       call mpi_type_indexed( count, blocklens, displs*blocklens(1),  &
  51       &                         MPI_DOUBLE_PRECISION, type, ierr )
  52
  53       call mpi_type_commit( type, ierr )
  54
  55 ! send using this new type
  56
  57       if (rank .eq. 0) then
  58
  59           call mpi_send( sndbuf(1,1), 1, type, 1, 0, MPI_COMM_WORLD,ierr )
  60
  61       else if (rank .eq. 1) then
  62
  63           xfersize=count * blocklens(1)
  64           call mpi_recv( rcvbuf(1,1), xfersize, MPI_DOUBLE_PRECISION, 0, 0, &
  65            &   MPI_COMM_WORLD,status, ierr )
  66
  67
  68 ! Values that should be sent
  69
  70         if (verbose) then
  71 !       displacement = 0
  72             j=1
  73             do i=1, 7
  74                print*,'sndbuf(',i,j,') = ',sndbuf(i,j)
  75             enddo
  76
  77 !       displacement = 10
  78             j=11
  79             do i=1,7
  80                print*,'sndbuf(',i,j,') = ',sndbuf(i,j)
  81             enddo
  82             print*,' '
  83
  84 ! Values received
  85             do j=1,count
  86                 do i=1,7
  87                     print*,'rcvbuf(',i,j,') = ',rcvbuf(i,j)
  88                 enddo
  89             enddo
  90         endif
  91
  92 ! Error checking
  93         do j=1,2
  94            do i=1,7
  95              if (rcvbuf(i,j) .ne. sndbuf(i,1)) then
  96                 print*,'ERROR in rcvbuf(',i,j,')'
  97                 print*,'Received ', rcvbuf(i,j),' expected ',sndbuf(i,11)
  98                 errs = errs+1
  99              endif
 100            enddo
 101         enddo
 102
 103         do j=3,4
 104            do i=1,7
 105               if (rcvbuf(i,j) .ne. sndbuf(i,11)) then
 106                 print*,'ERROR in rcvbuf(',i,j,')'
 107                 print*,'Received ', rcvbuf(i,j),' expected ',sndbuf(i,11)
 108                 errs = errs+1
 109               endif
 110            enddo
 111         enddo
 112       endif
 113 !
 114       call mpi_type_free( type, ierr )
 115       call mtest_finalize( errs )
 116       call mpi_finalize( ierr )
 117
 118       end