libgomp/testsuite/libgomp.fortran/vla2.f90

   1 ! { dg-do run }
   2
   3   call test
   4 contains
   5   subroutine check (x, y, l)
   6     integer :: x, y
   7     logical :: l
   8     l = l .or. x .ne. y
   9   end subroutine check
  10
  11   subroutine foo (c, d, e, f, g, h, i, j, k, n)
  12     use omp_lib
  13     integer :: n
  14     character (len = *) :: c
  15     character (len = n) :: d
  16     integer, dimension (2, 3:5, n) :: e
  17     integer, dimension (2, 3:n, n) :: f
  18     character (len = *), dimension (5, 3:n) :: g
  19     character (len = n), dimension (5, 3:n) :: h
  20     real, dimension (:, :, :) :: i
  21     double precision, dimension (3:, 5:, 7:) :: j
  22     integer, dimension (:, :, :) :: k
  23     logical :: l
  24     integer :: p, q, r
  25     character (len = n) :: s
  26     integer, dimension (2, 3:5, n) :: t
  27     integer, dimension (2, 3:n, n) :: u
  28     character (len = n), dimension (5, 3:n) :: v
  29     character (len = 2 * n + 24) :: w
  30     integer :: x
  31     character (len = 1) :: y
  32     l = .false.
  33 !$omp parallel default (none) private (c, d, e, f, g, h, i, j, k) &
  34 !$omp & private (s, t, u, v) reduction (.or.:l) num_threads (6) &
  35 !$omp private (p, q, r, w, x, y)
  36     x = omp_get_thread_num ()
  37     w = ''
  38     if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
  39     if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
  40     if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
  41     if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
  42     if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
  43     if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
  44     c = w(8:19)
  45     d = w(1:7)
  46     forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r
  47     forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r
  48     forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19)
  49     forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38)
  50     forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7)
  51     forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26)
  52     forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r
  53     forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r
  54     forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r
  55     s = w(20:26)
  56     forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r
  57     forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r
  58     forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7)
  59     forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26)
  60 !$omp barrier
  61     y = ''
  62     if (x .eq. 0) y = '0'
  63     if (x .eq. 1) y = '1'
  64     if (x .eq. 2) y = '2'
  65     if (x .eq. 3) y = '3'
  66     if (x .eq. 4) y = '4'
  67     if (x .eq. 5) y = '5'
  68     l = l .or. w(7:7) .ne. y
  69     l = l .or. w(19:19) .ne. y
  70     l = l .or. w(26:26) .ne. y
  71     l = l .or. w(38:38) .ne. y
  72     l = l .or. c .ne. w(8:19)
  73     l = l .or. d .ne. w(1:7)
  74     l = l .or. s .ne. w(20:26)
  75     do 103, p = 1, 2
  76       do 103, q = 3, 7
  77         do 103, r = 1, 7
  78           if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r
  79           l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r
  80           if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19)
  81           if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38)
  82           if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7)
  83           if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26)
  84           if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r
  85           l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r
  86           if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7)
  87           if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26)
  88 103 continue
  89     do 104, p = 3, 5
  90       do 104, q = 2, 6
  91         do 104, r = 1, 7
  92           l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r
  93           l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r
  94 104 continue
  95     do 105, p = 1, 5
  96       do 105, q = 4, 6
  97         l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
  98 105 continue
  99     call check (size (e, 1), 2, l)
 100     call check (size (e, 2), 3, l)
 101     call check (size (e, 3), 7, l)
 102     call check (size (e), 42, l)
 103     call check (size (f, 1), 2, l)
 104     call check (size (f, 2), 5, l)
 105     call check (size (f, 3), 7, l)
 106     call check (size (f), 70, l)
 107     call check (size (g, 1), 5, l)
 108     call check (size (g, 2), 5, l)
 109     call check (size (g), 25, l)
 110     call check (size (h, 1), 5, l)
 111     call check (size (h, 2), 5, l)
 112     call check (size (h), 25, l)
 113     call check (size (i, 1), 3, l)
 114     call check (size (i, 2), 5, l)
 115     call check (size (i, 3), 7, l)
 116     call check (size (i), 105, l)
 117     call check (size (j, 1), 4, l)
 118     call check (size (j, 2), 5, l)
 119     call check (size (j, 3), 7, l)
 120     call check (size (j), 140, l)
 121     call check (size (k, 1), 5, l)
 122     call check (size (k, 2), 1, l)
 123     call check (size (k, 3), 3, l)
 124     call check (size (k), 15, l)
 125 !$omp end parallel
 126     if (l) call abort
 127   end subroutine foo
 128
 129   subroutine test
 130     character (len = 12) :: c
 131     character (len = 7) :: d
 132     integer, dimension (2, 3:5, 7) :: e
 133     integer, dimension (2, 3:7, 7) :: f
 134     character (len = 12), dimension (5, 3:7) :: g
 135     character (len = 7), dimension (5, 3:7) :: h
 136     real, dimension (3:5, 2:6, 1:7) :: i
 137     double precision, dimension (3:6, 2:6, 1:7) :: j
 138     integer, dimension (1:5, 7:7, 4:6) :: k
 139     integer :: p, q, r
 140     call foo (c, d, e, f, g, h, i, j, k, 7)
 141   end subroutine test
 142 end