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 = 100*(1+coords(2))+(1+coords(1))
    write(*,"(4(A,I4))") "For process ",cart_rank," coords=(",coords(1),",",coords(2), &
          & "), cval = ",cval
          
	call SendToRootAndWrite(cval)
	
!   Now send value to the process on the right
    IF ( cart_rank == 0 ) WRITE(*,"(A)") "Send values in direction (0,1)"
    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)
   	call SendToRootAndWrite(cval)
   	              
!   Now send value downwards
    IF ( cart_rank == 0 ) WRITE(*,"(A)") "Send values in direction (1,0)"
    CALL MPI_CART_SHIFT(cart_comm, 1, 1, source, dest, ierr)
    CALL MPI_SENDRECV_REPLACE(cval, 1, MPI_INTEGER, dest, 0, source, 0, cart_comm, &
              status, ierr)
              
   	call SendToRootAndWrite(cval)
!
    call MPI_FINALIZE(ierr)
CONTAINS
	SUBROUTINE SendToRootAndWrite(sendvalue)
	   IMPLICIT NONE
	   INTEGER, INTENT(IN) :: sendvalue
       numvalues=1
       values = 0
!      Collectively send value to root process
       call MPI_Gather ( sendvalue, 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
       RETURN
    END SUBROUTINE SendToRootAndWrite
END PROGRAM Cart_create