PROGRAM Cart_create
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      integer :: i, j, p, q
      real :: p_real
      integer :: my_rank, cart_rank, source, dest
      integer :: ierr
      INTEGER, DIMENSION(2) :: ldims, coords
      LOGICAL, DIMENSION(2) :: periods, reorder	
	  INTEGER :: cart_comm
      integer, dimension(MPI_STATUS_SIZE) :: status
	  INTEGER :: cval, numvalues
	  INTEGER, DIMENSION(:), allocatable :: values
!
      call MPI_INIT( ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD,  p, ierr )
      call MPI_COMM_RANK(MPI_COMM_WORLD,  my_rank, ierr )
!
      p_real = p
      q =  sqrt(p_real)
      if ( q**2 /= p ) then
         if ( my_rank == 0 ) print*,q,"**2 /= ",p,": program terminates"
         call MPI_FINALIZE(ierr)
         stop
      end if
!
	  allocate(values(p),STAT=ierr)
	  if ( ierr /= 0 ) then
	  	  print*,"Error allocating values(",p,"): program terminates"
         call MPI_FINALIZE(ierr)
         stop
      end if
!
!     Create new communicator QxQ dimensions
!
	ldims(:) = q
	periods(:) = .TRUE.
	reorder = .FALSE.
	call MPI_Cart_Create(MPI_COMM_WORLD,2,ldims,periods,reorder,cart_comm, ierr)
!   Get process coordinates
    call MPI_COMM_RANK(cart_comm,  cart_rank, ierr )
	call mpi_cart_coords(cart_comm, cart_rank, 2, coords, ierr)
!   Each process defines a value equal to 2nd coordinate
	cval = coords(1)
    numvalues=1
    values = 0
!   Collectively send value to root process
    call MPI_Gather ( cval, 1, MPI_INTEGER, values, &
		& numvalues, MPI_INTEGER, 0, cart_comm, ierr )
    if ( cart_rank == 0 ) then
       PRINT*,"Before sending, values = "
       DO i = 0, q-1
          DO j = 0, q-1
             p = i + q*j +1
             WRITE(*,"(1X,I4)",ADVANCE="NO") values(p)
          END DO
          WRITE(*,"(1X)")
       END DO
    end if
!   Now send value to the process on the right
    CALL MPI_CART_SHIFT(cart_comm, 0, 1, source, dest, ierr)
    CALL MPI_SENDRECV_REPLACE(cval, 1, MPI_INTEGER, dest, 0, source, 0, cart_comm, &
              status, ierr)
!   Again, collectively send value to root process
    numvalues=1
	call MPI_Gather ( cval, 1, MPI_INTEGER, values, &
		& numvalues, MPI_INTEGER, 0, cart_comm, ierr )
    if ( cart_rank == 0 ) then
       PRINT*,"After sending, values = "
       DO i = 0, q-1
          DO j = 0, q-1
             p = i + q*j +1
             WRITE(*,"(1X,I4)",ADVANCE="NO") values(p)
          END DO
          WRITE(*,"(1X)")
       END DO
    end if
!
    call MPI_FINALIZE(ierr)
END PROGRAM Cart_create