PROGRAM p

   IMPLICIT NONE

   INTEGER, PARAMETER :: N = 500
   INTEGER :: a(N,N,6)
   integer na, ni

   a(:,:,1:3) = 1
   a(:,:,4:6) = 2

   WRITE (*,*) "Before Assignment:"
   WRITE (*,*) " a(1:2,1:2,1:3) = ", a(1:2,1:2,1:3)
   WRITE (*,*) " a(1:2,1:2,4:6) = ", a(1:2,1:2,4:6)

   na = size ( a )
   ni = size ( a(:,:,4:6) )
   write (*,*) 'size A   =', na
   write (*,*) 'Size sec =', ni
   call move_block ( a(1,1,4), a(1,1,1) , ni )   ! copy back

   WRITE (*,*) "After Assignment:"
   WRITE (*,*) " a(1:2,1:2,1:3) = ", a(1:2,1:2,1:3)
   WRITE (*,*) " a(1:2,1:2,4:6) = ", a(1:2,1:2,4:6)

   call move_block ( a(1,1,1), a(1,1,4) , ni )   ! copy forward
   call move_block ( a(1,1,2), a(1,1,1) , ni )   ! overwrite back
   call move_block ( a(1,1,1), a(1,1,2) , ni )   ! overwrite forward

   write (*,*) 'Now use array section for ', ni*4./1024./1024.,' mb'
   pause
   call mess_stack (a)
   a(:,:,1:3) = a(:,:,4:6)
   STOP

END PROGRAM p

subroutine mess_stack (a)
   INTEGER, PARAMETER :: N = 500
   INTEGER :: a(N,N,6)
!
   a(:,:,1:3) = a(:,:,4:6)

end

subroutine move_block (from, to, n )
!
   integer n, from(n), to(n), i
   logical report
!
   report = n > 10000
!
   if (report) write (*,1) ' '
   if (report) write (*,1) 'moving Array from ', loc(from),' to ',loc(to)
 1 format (a,i0,a,i0)
!
   if ( loc (to(n)) < loc (from) ) then         ! to(end) is before from(start) so no overwrite
      if (report) write (*,1) 'copying back ', n
      do i = 1,n
        to(i) = from(i)
      end do
!
   else if ( loc (to) > loc (from(n)) ) then    ! to is fully past from so no overwrite
      if (report) write (*,1) 'copying forward ', n
      do i = 1,n
        to(i) = from(i)
      end do
!
   else if ( loc (to) < loc (from) ) then       ! to is before from so overwrite DO in order
      if (report) write (*,1) 'overwriting back ', n
      do i = 1,n
        to(i) = from(i)
      end do
!
   else                                         ! to is after so overwrite DO backwards
      if (report) write (*,1) 'overwriting forward ', n
      do i = n,1,-1
        to(i) = from(i)
      end do
!
   end if

end subroutine move_block