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