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 upto 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
69