1 ! This file created from test/mpi/f77/datatype/hindexed_blockf.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 recvbuf(6*max_asizev)
17 integer sendbuf(max_asizev), status(MPI_STATUS_SIZE)
22 call mtest_init( ierr )
24 call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
25 call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
27 call mpi_type_size( MPI_INTEGER, intsize, ierr )
30 aintv(2) = 3 * intsize
31 call mpi_type_create_resized( MPI_INTEGER, aintv(1), aintv(2), &
33 call mpi_type_commit( type1, ierr )
36 call mpi_type_get_extent( type1, aintv(1), aintv(2), ierr )
37 if (aintv(1) .ne. 0) then
39 print *, 'Did not get expected lb'
41 if (aintv(2) .ne. 3*intsize) then
43 print *, 'Did not get expected extent'
47 call mpi_type_get_true_extent( type1, aintv(1), aintv(2), ierr )
48 if (aintv(1) .ne. 0) then
50 print *, 'Did not get expected true lb'
52 if (aintv(2) .ne. intsize) then
54 print *, 'Did not get expected true extent (', aintv(2), ') ', &
55 & ' expected ', intsize
60 aintv(i) = (i-1) * 3 * intsize
62 call mpi_type_create_hindexed( 10, blocklens, aintv, &
63 & MPI_INTEGER, type2, ierr )
64 call mpi_type_commit( type2, ierr )
67 call mpi_type_create_hvector( 10, 1, aint, MPI_INTEGER, type3, &
69 call mpi_type_commit( type3, ierr )
73 dtypes(i) = MPI_INTEGER
74 aintv(i) = (i-1) * 3 * intsize
76 call mpi_type_create_struct( 10, blocklens, aintv, dtypes, &
78 call mpi_type_commit( type4, ierr )
80 call mpi_type_get_extent(MPI_INTEGER, aintv(1), aint, ierr)
82 aintv(i) = (i-1) * 3 * aint
84 call mpi_type_create_hindexed_block( 10, 1, aintv, &
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 )