teshsuite/smpi/mpich3-test/f77/datatype/packef.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 ierr, errs
  10        integer inbuf(10), ioutbuf(10), inbuf2(10), ioutbuf2(10)
  11        integer i, insize, rsize, csize, insize2
  12        character*(16) cbuf, coutbuf
  13        double precision rbuf(10), routbuf(10)
  14        integer packbuf(1000), pbufsize, intsize
  15        integer max_asizev
  16        parameter (max_asizev = 3)
  17        include 'typeaints.h'
  18
  19        errs = 0
  20        call mtest_init( ierr )
  21
  22        call mpi_type_size( MPI_INTEGER, intsize, ierr )
  23        pbufsize = 1000 * intsize
  24
  25        call mpi_pack_external_size( 'external32', 10, MPI_INTEGER,
  26      &                              aint, ierr )
  27        if (aint .ne. 10 * 4) then
  28           errs = errs + 1
  29           print *, 'Expected 40 for size of 10 external32 integers',
  30      &       ', got ', aint
  31        endif
  32        call mpi_pack_external_size( 'external32', 10, MPI_LOGICAL,
  33      &                              aint, ierr )
  34        if (aint .ne. 10 * 4) then
  35           errs = errs + 1
  36           print *, 'Expected 40 for size of 10 external32 logicals',
  37      &       ', got ', aint
  38        endif
  39        call mpi_pack_external_size( 'external32', 10, MPI_CHARACTER,
  40      &                              aint, ierr )
  41        if (aint .ne. 10 * 1) then
  42           errs = errs + 1
  43           print *, 'Expected 10 for size of 10 external32 characters',
  44      &       ', got ', aint
  45        endif
  46
  47        call mpi_pack_external_size( 'external32', 3, MPI_INTEGER2,
  48      &                              aint, ierr )
  49        if (aint .ne. 3 * 2) then
  50           errs = errs + 1
  51           print *, 'Expected 6 for size of 3 external32 INTEGER*2',
  52      &       ', got ', aint
  53        endif
  54        call mpi_pack_external_size( 'external32', 3, MPI_INTEGER4,
  55      &                              aint, ierr )
  56        if (aint .ne. 3 * 4) then
  57           errs = errs + 1
  58           print *, 'Expected 12 for size of 3 external32 INTEGER*4',
  59      &       ', got ', aint
  60        endif
  61        call mpi_pack_external_size( 'external32', 3, MPI_REAL4,
  62      &                              aint, ierr )
  63        if (aint .ne. 3 * 4) then
  64           errs = errs + 1
  65           print *, 'Expected 12 for size of 3 external32 REAL*4',
  66      &       ', got ', aint
  67        endif
  68        call mpi_pack_external_size( 'external32', 3, MPI_REAL8,
  69      &                              aint, ierr )
  70        if (aint .ne. 3 * 8) then
  71           errs = errs + 1
  72           print *, 'Expected 24 for size of 3 external32 REAL*8',
  73      &       ', got ', aint
  74        endif
  75        if (MPI_INTEGER1 .ne. MPI_DATATYPE_NULL) then
  76           call mpi_pack_external_size( 'external32', 3, MPI_INTEGER1,
  77      &                              aint, ierr )
  78           if (aint .ne. 3 * 1) then
  79              errs = errs + 1
  80              print *, 'Expected 3 for size of 3 external32 INTEGER*1',
  81      &            ', got ', aint
  82           endif
  83        endif
  84        if (MPI_INTEGER8 .ne. MPI_DATATYPE_NULL) then
  85           call mpi_pack_external_size( 'external32', 3, MPI_INTEGER8,
  86      &                              aint, ierr )
  87           if (aint .ne. 3 * 8) then
  88              errs = errs + 1
  89              print *, 'Expected 24 for size of 3 external32 INTEGER*8',
  90      &            ', got ', aint
  91           endif
  92        endif
  93
  94 C
  95 C Initialize values
  96 C
  97        insize = 10
  98        do i=1, insize
  99           inbuf(i) = i
 100        enddo
 101        rsize = 3
 102        do i=1, rsize
 103           rbuf(i) = 1000.0 * i
 104        enddo
 105        cbuf  = 'This is a string'
 106        csize = 16
 107        insize2 = 7
 108        do i=1, insize2
 109           inbuf2(i) = 5000-i
 110        enddo
 111 C
 112        aintv(1) = pbufsize
 113        aintv(2) = 0
 114        aintv(3) = 0
 115 C One MPI implementation failed to increment the position; instead,
 116 C it set the value with the amount of data packed in this call
 117 C We use aintv(3) to detect and report this specific error
 118        call mpi_pack_external( 'external32', inbuf, insize, MPI_INTEGER,
 119      &               packbuf, aintv(1), aintv(2), ierr )
 120        if (aintv(2) .le. aintv(3)) then
 121             print *, ' Position decreased after pack of integer!'
 122        endif
 123        aintv(3) = aintv(2)
 124        call mpi_pack_external( 'external32', rbuf, rsize,
 125      &               MPI_DOUBLE_PRECISION, packbuf, aintv(1),
 126      &               aintv(2), ierr )
 127        if (aintv(2) .le. aintv(3)) then
 128             print *, ' Position decreased after pack of real!'
 129        endif
 130        aintv(3) = aintv(2)
 131        call mpi_pack_external( 'external32', cbuf, csize,
 132      &               MPI_CHARACTER, packbuf, aintv(1),
 133      &               aintv(2), ierr )
 134        if (aintv(2) .le. aintv(3)) then
 135             print *, ' Position decreased after pack of character!'
 136        endif
 137        aintv(3) = aintv(2)
 138        call mpi_pack_external( 'external32', inbuf2, insize2,
 139      &               MPI_INTEGER,
 140      &               packbuf, aintv(1), aintv(2), ierr )
 141        if (aintv(2) .le. aintv(3)) then
 142             print *, ' Position decreased after pack of integer (2nd)!'
 143        endif
 144        aintv(3) = aintv(2)
 145 C
 146 C We could try sending this with MPI_BYTE...
 147        aintv(2) = 0
 148        call mpi_unpack_external( 'external32', packbuf, aintv(1),
 149      &  aintv(2), ioutbuf, insize, MPI_INTEGER, ierr )
 150        call mpi_unpack_external( 'external32', packbuf, aintv(1),
 151      &  aintv(2), routbuf, rsize, MPI_DOUBLE_PRECISION, ierr )
 152        call mpi_unpack_external( 'external32', packbuf, aintv(1),
 153      &  aintv(2), coutbuf, csize, MPI_CHARACTER, ierr )
 154        call mpi_unpack_external( 'external32', packbuf, aintv(1),
 155      &  aintv(2), ioutbuf2, insize2, MPI_INTEGER, ierr )
 156 C
 157 C Now, test the values
 158 C
 159        do i=1, insize
 160           if (ioutbuf(i) .ne. i) then
 161              errs = errs + 1
 162              print *, 'ioutbuf(',i,') = ', ioutbuf(i), ' expected ', i
 163           endif
 164        enddo
 165        do i=1, rsize
 166           if (routbuf(i) .ne. 1000.0 * i) then
 167              errs = errs + 1
 168              print *, 'routbuf(',i,') = ', routbuf(i), ' expected ',       &
 169      &                1000.0 * i
 170           endif
 171        enddo
 172        if (coutbuf(1:csize) .ne. 'This is a string') then
 173           errs = errs + 1
 174           print *, 'coutbuf = ', coutbuf(1:csize), ' expected ',           &
 175      &             'This is a string'
 176        endif
 177        do i=1, insize2
 178           if (ioutbuf2(i) .ne. 5000-i) then
 179              errs = errs + 1
 180              print *, 'ioutbuf2(',i,') = ', ioutbuf2(i), ' expected ',     &
 181      &              5000-i
 182           endif
 183        enddo
 184 C
 185        call mtest_finalize( errs )
 186        call mpi_finalize( ierr )
 187        end