gcc/testsuite/gfortran.dg/coarray_16.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fcoarray=single" }
   3 !
   4 ! Run-time test for IMAGE_INDEX with cobounds only known at
   5 ! the compile time, suitable for any number of NUM_IMAGES()
   6 ! For compile-time cobounds, the -fcoarray=lib version still
   7 ! needs to run-time evalulation if image_index returns > 1
   8 ! as image_index is 0 if the index would exceed num_images().
   9 !
  10 ! Please set num_images() to >= 13, if possible.
  11 !
  12 ! PR fortran/18918
  13 !
  14
  15 program test_image_index
  16 implicit none
  17 integer :: index1, index2, index3
  18 logical :: one
  19
  20 integer, allocatable :: a(:)[:,:,:], b(:)[:,:], c(:,:)[:]
  21 integer, save :: d(2)[-1:3, *]
  22 integer, save :: e(2)[-1:-1, 3:*]
  23
  24 one = num_images() == 1
  25
  26 allocate(a(1)[3:3, -4:-3, 88:*])
  27 allocate(b(2)[-1:0,0:*])
  28 allocate(c(3,3)[*])
  29
  30 index1 = image_index(a, [3, -4, 88] )
  31 index2 = image_index(b, [-1, 0] )
  32 index3 = image_index(c, [1] )
  33 if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()
  34
  35
  36 index1 = image_index(a, [3, -3, 88] )
  37 index2 = image_index(b, [0, 0] )
  38 index3 = image_index(c, [2] )
  39
  40 if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) &
  41   call abort()
  42 if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) &
  43   call abort()
  44
  45
  46 index1 = image_index(d, [-1, 1] )
  47 index2 = image_index(d, [0, 1] )
  48
  49 if (one .and. (index1 /= 1 .or. index2 /= 0)) &
  50   call abort()
  51 if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &
  52   call abort()
  53
  54 index1 = image_index(e, [-1, 3] )
  55 index2 = image_index(e, [-1, 4] )
  56
  57 if (one .and. (index1 /= 1 .or. index2 /= 0)) &
  58   call abort()
  59 if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &
  60   call abort()
  61
  62 call test(1, a,b,c)
  63
  64 ! The following test is in honour of the F2008 standard:
  65 deallocate(a)
  66 allocate(a (10) [10, 0:9, 0:*])
  67
  68 index1 = image_index(a, [1, 0, 0] )
  69 index2 = image_index(a, [3, 1, 2] )  ! = 213, yeah!
  70 index3 = image_index(a, [3, 1, 0] )  ! = 13
  71
  72 if (num_images() < 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 0)) &
  73   call abort()
  74 if (num_images() >= 213 .and. (index1 /= 1 .or. index2 /= 213 .or. index3 /= 13)) &
  75   call abort()
  76 if (num_images() >= 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 13)) &
  77   call abort()
  78
  79
  80 contains
  81 subroutine test(n, a, b, c)
  82   integer :: n
  83   integer :: a(1)[3*n:3*n, -4*n:-3*n, 88*n:*], b(2)[-1*n:0*n,0*n:*], c(3*n,3*n)[*]
  84
  85   index1 = image_index(a, [3, -4, 88] )
  86   index2 = image_index(b, [-1, 0] )
  87   index3 = image_index(c, [1] )
  88   if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()
  89
  90
  91   index1 = image_index(a, [3, -3, 88] )
  92   index2 = image_index(b, [0, 0] )
  93   index3 = image_index(c, [2] )
  94
  95   if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) &
  96     call abort()
  97   if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) &
  98     call abort()
  99 end subroutine test
 100 end program test_image_index