9 integer errors, toterrors
10 integer comm_temp, comm_cart, new_comm
12 logical periods(NUM_DIMS)
13 integer dims(NUM_DIMS)
14 integer coords(NUM_DIMS)
15 integer new_coords(NUM_DIMS)
16 logical remain_dims(NUM_DIMS)
28 call MPI_COMM_RANK( MPI_COMM_WORLD, rank, ierr)
29 call MPI_COMM_SIZE (MPI_COMM_WORLD, size, ierr )
32 c Clear dims array and get dims for topology
38 call MPI_DIMS_CREATE( size, NUM_DIMS, dims, ierr)
41 c Make a new communicator with a topology
44 call MPI_CART_CREATE( MPI_COMM_WORLD, 2, dims, periods,
45 $ reorder, comm_temp, ierr)
46 call MPI_COMM_DUP (comm_temp, comm_cart, ierr)
49 c Determine the status of the new communicator
51 call MPI_TOPO_TEST (comm_cart, topo_status, ierr)
52 IF (topo_status .ne. MPI_CART) then
53 print *, "Topo_status is not MPI_CART"
58 c How many dims do we have?
60 call MPI_CARTDIM_GET( comm_cart, ndims, ierr)
61 if (ndims .ne. NUM_DIMS ) then
62 print *, "ndims (", ndims, ") is not NUM_DIMS (", NUMDIMS,
68 c Get the topology, does it agree with what we put in?
74 call MPI_CART_GET( comm_cart, NUM_DIMS, dims, periods, coords,
77 c Does the mapping from coords to rank work?
79 call MPI_CART_RANK( comm_cart, coords, new_rank, ierr)
80 if (new_rank .ne. rank ) then
81 print *, "New_rank = ", new_rank, " is not rank (", rank, ")"
86 c Does the mapping from rank to coords work
88 call MPI_CART_COORDS( comm_cart, rank, NUM_DIMS, new_coords ,
91 if (coords(i) .ne. new_coords(i)) then
92 print *, "coords(",i,") = ", coords(i), " not = ",
99 c Let's shift in each dimension and see how it works!
100 c Because it's late and I'm tired, I'm not making this
101 c automatically test itself.
104 call MPI_CART_SHIFT( comm_cart, (i-1), 1, source, dest, ierr)
105 c print *, '[', rank, '] shifting 1 in the ', (i-1),
107 c print *, '[', rank, '] source = ', source,
115 remain_dims(1)=.false.
117 remain_dims(i)=.true.
119 call MPI_CART_SUB( comm_cart, remain_dims, new_comm, ierr)
122 c Determine the status of the new communicator
124 call MPI_TOPO_TEST( new_comm, topo_status, ierr )
125 if (topo_status .ne. MPI_CART ) then
126 print *, "Topo_status of new comm is not MPI_CART"
131 c How many dims do we have?
133 call MPI_CARTDIM_GET( new_comm, ndims, ierr)
134 if (ndims .ne. NUM_DIMS-1 ) then
135 print *, "ndims (", ndims, ") is not NUM_DIMS-1"
140 c Get the topology, does it agree with what we put in?
142 do 900 i=1,NUM_DIMS-1
146 call MPI_CART_GET( new_comm, ndims, dims, periods, coords, ierr)
149 c Does the mapping from coords to rank work?
151 call MPI_COMM_RANK( new_comm, newnewrank, ierr)
152 call MPI_CART_RANK( new_comm, coords, new_rank, ierr)
153 if (new_rank .ne. newnewrank ) then
154 print *, "New rank (", new_rank, ") is not newnewrank"
159 c Does the mapping from rank to coords work
161 call MPI_CART_COORDS( new_comm, new_rank, NUM_DIMS-1, new_coords
163 do 1000 i=1,NUM_DIMS-1
164 if (coords(i) .ne. new_coords(i)) then
165 print *, "coords(",i,") = ", coords(i),
166 $ " != new_coords (", new_coords(i), ")"
174 call MPI_COMM_FREE( new_comm, ierr)
175 call MPI_COMM_FREE( comm_temp, ierr)
176 call MPI_COMM_FREE( comm_cart, ierr)
178 c call Test_Waitforall_( )
180 call MPI_ALLREDUCE( errors, toterrors, 1, MPI_INTEGER,
181 1 MPI_SUM, MPI_COMM_WORLD, ierr )
182 if (rank .eq. 0) then
183 if (toterrors .eq. 0) then
184 print *, ' No Errors'
186 print *, ' Done with ', toterrors, ' ERRORS!'
189 call MPI_FINALIZE(ierr)
190 c print *, '[', rank, '] done with ', errors, ' ERRORS!'