Subversion Repositories openrisc

! { dg-do run }

!

! Scalar coarray

!

! Run-time test for IMAGE_INDEX with cobounds only known at

! the compile time, suitable for any number of NUM_IMAGES()

! For compile-time cobounds, the -fcoarray=lib version still

! needs to run-time evalulation if image_index returns > 1

! as image_index is 0 if the index would exceed num_images().

!

! Please set num_images() to >= 13, if possible.

!

! PR fortran/18918

!

program test_image_index

implicit none

integer :: index1, index2, index3

logical :: one

integer, save :: d[-1:3, *]

integer, save :: e[-1:-1, 3:*]

one = num_images() == 1

index1 = image_index(d, [-1, 1] )

index2 = image_index(d, [0, 1] )

if (one .and. (index1 /= 1 .or. index2 /= 0)) &

  call abort()

if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &

  call abort()

index1 = image_index(e, [-1, 3] )

index2 = image_index(e, [-1, 4] )

if (one .and. (index1 /= 1 .or. index2 /= 0)) &

  call abort()

if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &

  call abort()

call test(1, e, d, e)

call test(2, e, d, e)

contains

subroutine test(n, a, b, c)

  integer :: n

  integer :: a[3*n:3*n, -4*n:-3*n, 88*n:*], b[-1*n:0*n,0*n:*], c[*]

  index1 = image_index(a, [3*n, -4*n, 88*n] )

  index2 = image_index(b, [-1, 0] )

  index3 = image_index(c, [1] )

  if (n == 1) then

    if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()

  else if (num_images() == 1) then

    if (index1 /= 1 .or. index2 /= 0 .or. index3 /= 1) call abort()

  else

    if (index1 /= 1 .or. index2 /= 2 .or. index3 /= 1) call abort()

  end if

  index1 = image_index(a, [3*n, -3*n, 88*n] )

  index2 = image_index(b, [0, 0] )

  index3 = image_index(c, [2] )

  if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) &

    call abort()

  if (n == 1 .and. num_images() == 2) then

    if (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2) &

      call abort()

  else if (n == 2 .and. num_images() == 2) then

    if (index1 /= 0 .or. index2 /= 0 .or. index3 /= 2) &

      call abort()

  end if

end subroutine test

end program test_image_index