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

   1 ! This file created from test/mpi/f77/datatype/hindexed_blockf.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 !  (C) 2003 by Argonne National Laboratory.
   5 !      See COPYRIGHT in top-level directory.
   6 !
   7       program main
   8       use mpi
   9       integer errs, ierr, i, intsize
  10       integer type1, type2, type3, type4, type5
  11       integer max_asizev
  12       parameter (max_asizev = 10)
  13       integer (kind=MPI_ADDRESS_KIND) aint, aintv(max_asizev)
  14
  15       integer blocklens(max_asizev), dtypes(max_asizev)
  16       integer displs(max_asizev)
  17       integer recvbuf(6*max_asizev)
  18       integer sendbuf(max_asizev), status(MPI_STATUS_SIZE)
  19       integer rank, size
  20
  21       errs = 0
  22
  23       call mtest_init( ierr )
  24
  25       call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
  26       call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
  27 !
  28       call mpi_type_size( MPI_INTEGER, intsize, ierr )
  29 !
  30       aintv(1) = 0
  31       aintv(2) = 3 * intsize
  32       call mpi_type_create_resized( MPI_INTEGER, aintv(1), aintv(2), &
  33       &                              type1, ierr )
  34       call mpi_type_commit( type1, ierr )
  35       aintv(1) = -1
  36       aintv(2) = -1
  37       call mpi_type_get_extent( type1, aintv(1), aintv(2), ierr )
  38       if (aintv(1) .ne. 0) then
  39          errs = errs + 1
  40          print *, 'Did not get expected lb'
  41       endif
  42       if (aintv(2) .ne. 3*intsize) then
  43          errs = errs + 1
  44          print *, 'Did not get expected extent'
  45       endif
  46       aintv(1) = -1
  47       aintv(2) = -1
  48       call mpi_type_get_true_extent( type1, aintv(1), aintv(2), ierr )
  49       if (aintv(1) .ne. 0) then
  50          errs = errs + 1
  51          print *, 'Did not get expected true lb'
  52       endif
  53       if (aintv(2) .ne. intsize) then
  54          errs = errs + 1
  55          print *, 'Did not get expected true extent (', aintv(2), ') ', &
  56       &     ' expected ', intsize
  57       endif
  58 !
  59       do i=1,10
  60          blocklens(i) = 1
  61          aintv(i)    = (i-1) * 3 * intsize
  62       enddo
  63       call mpi_type_create_hindexed( 10, blocklens, aintv, &
  64       &                               MPI_INTEGER, type2, ierr )
  65       call mpi_type_commit( type2, ierr )
  66 !
  67       aint = 3 * intsize
  68       call mpi_type_create_hvector( 10, 1, aint, MPI_INTEGER, type3, &
  69       &                              ierr )
  70       call mpi_type_commit( type3, ierr )
  71 !
  72       do i=1,10
  73          blocklens(i) = 1
  74          dtypes(i)    = MPI_INTEGER
  75          aintv(i)    = (i-1) * 3 * intsize
  76       enddo
  77       call mpi_type_create_struct( 10, blocklens, aintv, dtypes, &
  78       &                             type4, ierr )
  79       call mpi_type_commit( type4, ierr )
  80
  81       call mpi_type_get_extent(MPI_INTEGER, aintv(1), aint, ierr)
  82       do i=1,10
  83          aintv(i)    = (i-1) * 3 * aint
  84       enddo
  85       call mpi_type_create_hindexed_block( 10, 1, aintv, &
  86       &                               MPI_INTEGER, type5, ierr )
  87       call mpi_type_commit( type5, ierr )
  88 !
  89 ! Using each time, send and receive using these types
  90       do i=1, max_asizev*3
  91          recvbuf(i) = -1
  92       enddo
  93       do i=1, max_asizev
  94          sendbuf(i) = i
  95       enddo
  96       call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, &
  97       &                   recvbuf, max_asizev, type1, rank, 0, &
  98       &                   MPI_COMM_WORLD, status, ierr )
  99       do i=1, max_asizev
 100          if (recvbuf(1+(i-1)*3) .ne. i ) then
 101             errs = errs + 1
 102             print *, 'type1:', i, 'th element = ', recvbuf(1+(i-1)*3)
 103          endif
 104       enddo
 105 !
 106       do i=1, max_asizev*3
 107          recvbuf(i) = -1
 108       enddo
 109       do i=1, max_asizev
 110          sendbuf(i) = i
 111       enddo
 112       call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, &
 113       &                   recvbuf, 1, type2, rank, 0, &
 114       &                   MPI_COMM_WORLD, status, ierr )
 115       do i=1, max_asizev
 116          if (recvbuf(1+(i-1)*3) .ne. i ) then
 117             errs = errs + 1
 118             print *, 'type2:', i, 'th element = ', recvbuf(1+(i-1)*3)
 119          endif
 120       enddo
 121 !
 122       do i=1, max_asizev*3
 123          recvbuf(i) = -1
 124       enddo
 125       do i=1, max_asizev
 126          sendbuf(i) = i
 127       enddo
 128       call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, &
 129       &                   recvbuf, 1, type3, rank, 0, &
 130       &                   MPI_COMM_WORLD, status, ierr )
 131       do i=1, max_asizev
 132          if (recvbuf(1+(i-1)*3) .ne. i ) then
 133             errs = errs + 1
 134             print *, 'type3:', i, 'th element = ', recvbuf(1+(i-1)*3)
 135          endif
 136       enddo
 137 !
 138       do i=1, max_asizev*3
 139          recvbuf(i) = -1
 140       enddo
 141       do i=1, max_asizev
 142          sendbuf(i) = i
 143       enddo
 144       call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, &
 145       &                   recvbuf, 1, type4, rank, 0, &
 146       &                   MPI_COMM_WORLD, status, ierr )
 147       do i=1, max_asizev
 148          if (recvbuf(1+(i-1)*3) .ne. i ) then
 149             errs = errs + 1
 150             print *, 'type4:', i, 'th element = ', recvbuf(1+(i-1)*3)
 151          endif
 152       enddo
 153 !
 154       do i=1, max_asizev*3
 155          recvbuf(i) = -1
 156       enddo
 157       do i=1, max_asizev
 158          sendbuf(i) = i
 159       enddo
 160       call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, &
 161       &                   recvbuf, 1, type5, rank, 0, &
 162       &                   MPI_COMM_WORLD, status, ierr )
 163       do i=1, max_asizev
 164          if (recvbuf(1+(i-1)*3) .ne. i ) then
 165             errs = errs + 1
 166             print *, 'type5:', i, 'th element = ', recvbuf(1+(i-1)*3)
 167          endif
 168       enddo
 169 !
 170       call mpi_type_free( type1, ierr )
 171       call mpi_type_free( type2, ierr )
 172       call mpi_type_free( type3, ierr )
 173       call mpi_type_free( type4, ierr )
 174       call mpi_type_free( type5, ierr )
 175
 176       call mtest_finalize( errs )
 177       call mpi_finalize( ierr )
 178
 179       end