gcc/testsuite/gfortran.dg/coarray/image_index_3.f90

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