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

   1 ! This file created from test/mpi/f77/datatype/typem2f.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       do i=1,10
  82          displs(i)    = (i-1) * 3
  83       enddo
  84       call mpi_type_create_indexed_block( 10, 1, displs,  &
  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