	program main
	include 'mpif.h'


	integer NUM_DIMS
	parameter (NUM_DIMS=2)

	integer ierr
	integer errors, toterrors
	integer comm_temp, comm_cart, new_comm
	integer size, rank, i
	logical periods(NUM_DIMS)
	integer dims(NUM_DIMS)
	integer coords(NUM_DIMS)
	integer new_coords(NUM_DIMS)
	logical remain_dims(NUM_DIMS)
	integer newnewrank
	logical reorder
	integer topo_status
	integer ndims
	integer new_rank

	integer source, dest

	errors=0
	call MPI_INIT (ierr)

	call MPI_COMM_RANK( MPI_COMM_WORLD, rank, ierr)
	call MPI_COMM_SIZE (MPI_COMM_WORLD, size, ierr )

c
c    Clear dims array and get dims for topology 
c
	do 100 i=1,NUM_DIMS
		dims(i)=0
		periods(i)= .false.
100	continue
	call MPI_DIMS_CREATE( size, NUM_DIMS, dims, ierr)

c
c     Make a new communicator with a topology 
c
	reorder = .true.
	call MPI_CART_CREATE( MPI_COMM_WORLD, 2, dims, periods,  
     $ 		reorder, comm_temp, ierr)
	call MPI_COMM_DUP (comm_temp, comm_cart, ierr)

c
c     Determine the status of the new communicator 
c
	call MPI_TOPO_TEST (comm_cart, topo_status, ierr)
	IF (topo_status .ne. MPI_CART) errors=errors+1

c
c     How many dims do we have? 
c
	call MPI_CARTDIM_GET( comm_cart, ndims, ierr)
	if (ndims .ne. NUM_DIMS ) errors = errors+1

c
c     Get the topology, does it agree with what we put in? 
c
	do 500 i=1,NUM_DIMS
		dims(i)=0
		periods(i)=.false.
500	continue
	call MPI_CART_GET( comm_cart, NUM_DIMS, dims, periods, coords,
     $       ierr) 
c
c     Does the mapping from coords to rank work? 
c
	call MPI_CART_RANK( comm_cart, coords, new_rank, ierr)
	if (new_rank .ne. rank ) errors=errors+1

c
c     Does the mapping from rank to coords work 
c
	call MPI_CART_COORDS( comm_cart, rank, NUM_DIMS, new_coords ,
     $       ierr) 
	do 600 i=1,NUM_DIMS
		if (coords(i) .ne. new_coords(i)) errors=errors + 1
600	continue

c
c     Let's shift in each dimension and see how it works!  
c     Because it's late and I'm tired, I'm not making this 
c     automatically test itself.                          
c
	do 700 i=1,NUM_DIMS
           call MPI_CART_SHIFT( comm_cart, (i-1), 1, source, dest, ierr)
c 	    print *, '[', rank, '] shifting 1 in the ', (i-1), 
c     $			' dimension'
c 	    print *, '[', rank, ']     source = ', source, 
c     $			' dest = ', dest
		
700	continue

c
c     Subdivide 
c
	remain_dims(1)=.false.
	do 800 i=2,NUM_DIMS
		remain_dims(i)=.true.
800	continue
	call MPI_CART_SUB( comm_cart, remain_dims, new_comm, ierr)

c
c     Determine the status of the new communicator 
c
	call MPI_TOPO_TEST( new_comm, topo_status, ierr )
	if (topo_status .ne. MPI_CART ) errors=errors+1

c
c     How many dims do we have? 
c
	call MPI_CARTDIM_GET( new_comm, ndims, ierr)
	if (ndims .ne. NUM_DIMS-1 ) errors = errors+1

c
c     Get the topology, does it agree with what we put in? 
c
	do 900 i=1,NUM_DIMS-1
		dims(i)=0
		periods(i)=.false.
900	continue
	call MPI_CART_GET( new_comm, ndims, dims, periods, coords, ierr)
    
c
c     Does the mapping from coords to rank work? 
c
	call MPI_COMM_RANK( new_comm, newnewrank, ierr)
	call MPI_CART_RANK( new_comm, coords, new_rank, ierr)
	if (new_rank .ne. newnewrank ) errors=errors+1

c
c     Does the mapping from rank to coords work 
c
	call MPI_CART_COORDS( new_comm, new_rank, NUM_DIMS-1, new_coords
     $       ,  ierr)
	do 1000 i=1,NUM_DIMS-1
		if (coords(i) .ne. new_coords(i)) errors=errors+1
1000	continue

c
c     We're at the end 
c
	call MPI_COMM_FREE( new_comm, ierr)
	call MPI_COMM_FREE( comm_temp, ierr)
	call MPI_COMM_FREE( comm_cart, ierr)
	
c	call Test_Waitforall_( )

	call MPI_ALLREDUCE( errors, toterrors, 1, MPI_INTEGER,
     1                      MPI_SUM, MPI_COMM_WORLD, ierr )
	if (rank .eq. 0) then
	   print *, ' Done with ', toterrors, ' ERRORS!'
	endif
	call MPI_FINALIZE(ierr)
c	   print *, '[', rank, '] done with ', errors, ' ERRORS!'

	end
