teshsuite/smpi/mpich3-test/f77/datatype/typem2f.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, i, intsize
  10       integer type1, type2, type3, type4, type5
  11       integer max_asizev
  12       parameter (max_asizev = 10)
  13       include 'typeaints.h'
  14       integer blocklens(max_asizev), dtypes(max_asizev)
  15       integer displs(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 C
  27       call mpi_type_size( MPI_INTEGER, intsize, ierr )
  28 C
  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 C
  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 C
  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 C
  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       do i=1,10
  81          displs(i)    = (i-1) * 3
  82       enddo
  83       call mpi_type_create_indexed_block( 10, 1, displs,
  84      &                               MPI_INTEGER, type5, ierr )
  85       call mpi_type_commit( type5, ierr )
  86 C
  87 C Using each time, send and receive using these types
  88       do i=1, max_asizev*3
  89          recvbuf(i) = -1
  90       enddo
  91       do i=1, max_asizev
  92          sendbuf(i) = i
  93       enddo
  94       call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
  95      &                   recvbuf, max_asizev, type1, rank, 0,
  96      &                   MPI_COMM_WORLD, status, ierr )
  97       do i=1, max_asizev
  98          if (recvbuf(1+(i-1)*3) .ne. i ) then
  99             errs = errs + 1
 100             print *, 'type1:', i, 'th element = ', recvbuf(1+(i-1)*3)
 101          endif
 102       enddo
 103 C
 104       do i=1, max_asizev*3
 105          recvbuf(i) = -1
 106       enddo
 107       do i=1, max_asizev
 108          sendbuf(i) = i
 109       enddo
 110       call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
 111      &                   recvbuf, 1, type2, rank, 0,
 112      &                   MPI_COMM_WORLD, status, ierr )
 113       do i=1, max_asizev
 114          if (recvbuf(1+(i-1)*3) .ne. i ) then
 115             errs = errs + 1
 116             print *, 'type2:', i, 'th element = ', recvbuf(1+(i-1)*3)
 117          endif
 118       enddo
 119 C
 120       do i=1, max_asizev*3
 121          recvbuf(i) = -1
 122       enddo
 123       do i=1, max_asizev
 124          sendbuf(i) = i
 125       enddo
 126       call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
 127      &                   recvbuf, 1, type3, rank, 0,
 128      &                   MPI_COMM_WORLD, status, ierr )
 129       do i=1, max_asizev
 130          if (recvbuf(1+(i-1)*3) .ne. i ) then
 131             errs = errs + 1
 132             print *, 'type3:', i, 'th element = ', recvbuf(1+(i-1)*3)
 133          endif
 134       enddo
 135 C
 136       do i=1, max_asizev*3
 137          recvbuf(i) = -1
 138       enddo
 139       do i=1, max_asizev
 140          sendbuf(i) = i
 141       enddo
 142       call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
 143      &                   recvbuf, 1, type4, rank, 0,
 144      &                   MPI_COMM_WORLD, status, ierr )
 145       do i=1, max_asizev
 146          if (recvbuf(1+(i-1)*3) .ne. i ) then
 147             errs = errs + 1
 148             print *, 'type4:', i, 'th element = ', recvbuf(1+(i-1)*3)
 149          endif
 150       enddo
 151 C
 152       do i=1, max_asizev*3
 153          recvbuf(i) = -1
 154       enddo
 155       do i=1, max_asizev
 156          sendbuf(i) = i
 157       enddo
 158       call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
 159      &                   recvbuf, 1, type5, rank, 0,
 160      &                   MPI_COMM_WORLD, status, ierr )
 161       do i=1, max_asizev
 162          if (recvbuf(1+(i-1)*3) .ne. i ) then
 163             errs = errs + 1
 164             print *, 'type5:', i, 'th element = ', recvbuf(1+(i-1)*3)
 165          endif
 166       enddo
 167 C
 168       call mpi_type_free( type1, ierr )
 169       call mpi_type_free( type2, ierr )
 170       call mpi_type_free( type3, ierr )
 171       call mpi_type_free( type4, ierr )
 172       call mpi_type_free( type5, ierr )
 173
 174       call mtest_finalize( errs )
 175       call mpi_finalize( ierr )
 176
 177       end