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

   1 !
   2 !  (C) 2004 by Argonne National Laboratory.
   3 !      See COPYRIGHT in top-level directory.
   4 !
   5         program main
   6         use mpi
   7         integer ierr
   8         integer errs
   9         integer nints, nadds, ndtypes, combiner
  10         integer nparms(2), dummy(1)
  11         integer (kind=MPI_ADDRESS_KIND) adummy(1)
  12         integer ntype1, nsize, ntype2, ntype3, i
  13 !
  14 !       Test the Type_create_f90_xxx routines
  15 !
  16         errs = 0
  17         call mtest_init( ierr )
  18
  19 ! integers with up to 9 are 4 bytes integers; r of 4 are 2 byte,
  20 ! and r of 2 is 1 byte
  21         call mpi_type_create_f90_integer( 9, ntype1, ierr )
  22 !
  23 !       Check with get contents and envelope...
  24         call mpi_type_get_envelope( ntype1, nints, nadds, ndtypes, &
  25                                     combiner, ierr )
  26         if (nadds .ne. 0) then
  27            errs = errs + 1
  28            print *, "There should be no addresses on created type (r=9)"
  29         endif
  30         if (ndtypes .ne. 0) then
  31            errs = errs + 1
  32            print *, "There should be no datatypes on created type (r=9)"
  33         endif
  34         if (nints .ne. 1) then
  35            errs = errs + 1
  36            print *, "There should be exactly 1 integer on create type (r=9)"
  37         endif
  38         if (combiner .ne. MPI_COMBINER_F90_INTEGER) then
  39            errs = errs + 1
  40            print *, "The combiner should be INTEGER, not ", combiner
  41         endif
  42         if (nints .eq. 1) then
  43            call mpi_type_get_contents( ntype1, 1, 0, 0, &
  44                                        nparms, adummy, dummy, ierr )
  45            if (nparms(1) .ne. 9) then
  46               errs = errs + 1
  47               print *, "parameter was ", nparms(1), " should be 9"
  48            endif
  49         endif
  50
  51         call mpi_type_create_f90_integer( 8, ntype2, ierr )
  52         if (ntype1 .eq. ntype2) then
  53            errs = errs + 1
  54            print *, "Types with r = 8 and r = 9 are the same, ", &
  55                 "should be distinct"
  56         endif
  57
  58 !
  59 ! Check that we don't create new types each time.  This test will fail only
  60 ! if the MPI implementation checks for un-freed types or runs out of space
  61         do i=1, 100000
  62            call mpi_type_create_f90_integer( 8, ntype3, ierr )
  63         enddo
  64
  65         call mtest_finalize( errs )
  66         call mpi_finalize( ierr )
  67
  68         end