1 ! This file created from test/mpi/f77/datatype/typem2f.f with f77tof90
2 ! -*- Mode: Fortran; -*-
4 ! (C) 2003 by Argonne National Laboratory.
5 ! See COPYRIGHT in top-level directory.
9 integer errs, ierr, i, intsize
10 integer type1, type2, type3, type4, type5
12 parameter (max_asizev = 10)
13 integer (kind=MPI_ADDRESS_KIND) aint, aintv(max_asizev)
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)
23 call mtest_init( ierr )
25 call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
26 call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
28 call mpi_type_size( MPI_INTEGER, intsize, ierr )
31 aintv(2) = 3 * intsize
32 call mpi_type_create_resized( MPI_INTEGER, aintv(1), aintv(2), &
34 call mpi_type_commit( type1, ierr )
37 call mpi_type_get_extent( type1, aintv(1), aintv(2), ierr )
38 if (aintv(1) .ne. 0) then
40 print *, 'Did not get expected lb'
42 if (aintv(2) .ne. 3*intsize) then
44 print *, 'Did not get expected extent'
48 call mpi_type_get_true_extent( type1, aintv(1), aintv(2), ierr )
49 if (aintv(1) .ne. 0) then
51 print *, 'Did not get expected true lb'
53 if (aintv(2) .ne. intsize) then
55 print *, 'Did not get expected true extent (', aintv(2), ') ', &
56 & ' expected ', intsize
61 aintv(i) = (i-1) * 3 * intsize
63 call mpi_type_create_hindexed( 10, blocklens, aintv, &
64 & MPI_INTEGER, type2, ierr )
65 call mpi_type_commit( type2, ierr )
68 call mpi_type_create_hvector( 10, 1, aint, MPI_INTEGER, type3, &
70 call mpi_type_commit( type3, ierr )
74 dtypes(i) = MPI_INTEGER
75 aintv(i) = (i-1) * 3 * intsize
77 call mpi_type_create_struct( 10, blocklens, aintv, dtypes, &
79 call mpi_type_commit( type4, ierr )
84 call mpi_type_create_indexed_block( 10, 1, displs, &
85 & MPI_INTEGER, type5, ierr )
86 call mpi_type_commit( type5, ierr )
88 ! Using each time, send and receive using these types
95 call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, &
96 & recvbuf, max_asizev, type1, rank, 0, &
97 & MPI_COMM_WORLD, status, ierr )
99 if (recvbuf(1+(i-1)*3) .ne. i ) then
101 print *, 'type1:', i, 'th element = ', recvbuf(1+(i-1)*3)
111 call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, &
112 & recvbuf, 1, type2, rank, 0, &
113 & MPI_COMM_WORLD, status, ierr )
115 if (recvbuf(1+(i-1)*3) .ne. i ) then
117 print *, 'type2:', i, 'th element = ', recvbuf(1+(i-1)*3)
127 call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, &
128 & recvbuf, 1, type3, rank, 0, &
129 & MPI_COMM_WORLD, status, ierr )
131 if (recvbuf(1+(i-1)*3) .ne. i ) then
133 print *, 'type3:', i, 'th element = ', recvbuf(1+(i-1)*3)
143 call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, &
144 & recvbuf, 1, type4, rank, 0, &
145 & MPI_COMM_WORLD, status, ierr )
147 if (recvbuf(1+(i-1)*3) .ne. i ) then
149 print *, 'type4:', i, 'th element = ', recvbuf(1+(i-1)*3)
159 call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, &
160 & recvbuf, 1, type5, rank, 0, &
161 & MPI_COMM_WORLD, status, ierr )
163 if (recvbuf(1+(i-1)*3) .ne. i ) then
165 print *, 'type5:', i, 'th element = ', recvbuf(1+(i-1)*3)
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 )
175 call mtest_finalize( errs )
176 call mpi_finalize( ierr )