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

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