! { dg-do run } ! { dg-options "-std=legacy" } call test contains subroutine check (x, y, l) integer :: x, y logical :: l l = l .or. x .ne. y end subroutine check subroutine foo (c, d, e, f, g, h, i, j, k, n) use omp_lib integer :: n character (len = *) :: c character (len = n) :: d integer, dimension (2, 3:5, n) :: e integer, dimension (2, 3:n, n) :: f character (len = *), dimension (5, 3:n) :: g character (len = n), dimension (5, 3:n) :: h real, dimension (:, :, :) :: i double precision, dimension (3:, 5:, 7:) :: j integer, dimension (:, :, :) :: k logical :: l integer :: p, q, r character (len = n) :: s integer, dimension (2, 3:5, n) :: t integer, dimension (2, 3:n, n) :: u character (len = n), dimension (5, 3:n) :: v character (len = 2 * n + 24) :: w integer :: x, z character (len = 1) :: y s = 'PQRSTUV' forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + p - q + 2 * r forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - p + q - 2 * r forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = '_+|/Oo_' forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = '///|||!' l = .false. !$omp parallel default (none) shared (c, d, e, f, g, h, i, j, k) & !$omp & shared (s, t, u, v) reduction (.or.:l) num_threads (6) & !$omp private (p, q, r, w, x, y) l = l .or. c .ne. 'abcdefghijkl' l = l .or. d .ne. 'ABCDEFG' l = l .or. s .ne. 'PQRSTUV' do 100, p = 1, 2 do 100, q = 3, 7 do 100, r = 1, 7 if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 + p + q + 2 * r l = l .or. f(p, q, r) .ne. 25 + p + q + 2 * r if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. '0123456789AB' if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. '9876543210ZY' if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. '0123456' if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. '9876543' if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + p - q + 2 * r l = l .or. u(p, q, r) .ne. 30 - p + q - 2 * r if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. '_+|/Oo_' if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. '///|||!' 100 continue do 101, p = 3, 5 do 101, q = 2, 6 do 101, r = 1, 7 l = l .or. i(p - 2, q - 1, r) .ne. 7.5 * p * q * r l = l .or. j(p, q + 3, r + 6) .ne. 9.5 * p * q * r 101 continue do 102, p = 1, 5 do 102, q = 4, 6 l = l .or. k(p, 1, q - 3) .ne. 19 + p + 7 + 3 * q 102 continue do 110 z = 0, omp_get_num_threads () - 1 !$omp barrier x = omp_get_thread_num () w = '' if (z .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0' if (z .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1' if (z .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2' if (z .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3' if (z .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4' if (z .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5' if (x .eq. z) then c = w(8:19) d = w(1:7) forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19) forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38) forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7) forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26) forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r s = w(20:26) forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7) forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26) end if !$omp barrier x = z y = '' if (x .eq. 0) y = '0' if (x .eq. 1) y = '1' if (x .eq. 2) y = '2' if (x .eq. 3) y = '3' if (x .eq. 4) y = '4' if (x .eq. 5) y = '5' l = l .or. w(7:7) .ne. y l = l .or. w(19:19) .ne. y l = l .or. w(26:26) .ne. y l = l .or. w(38:38) .ne. y l = l .or. c .ne. w(8:19) l = l .or. d .ne. w(1:7) l = l .or. s .ne. w(20:26) do 103, p = 1, 2 do 103, q = 3, 7 do 103, r = 1, 7 if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19) if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38) if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7) if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26) if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7) if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26) 103 continue do 104, p = 3, 5 do 104, q = 2, 6 do 104, r = 1, 7 l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r 104 continue do 105, p = 1, 5 do 105, q = 4, 6 l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q 105 continue 110 continue call check (size (e, 1), 2, l) call check (size (e, 2), 3, l) call check (size (e, 3), 7, l) call check (size (e), 42, l) call check (size (f, 1), 2, l) call check (size (f, 2), 5, l) call check (size (f, 3), 7, l) call check (size (f), 70, l) call check (size (g, 1), 5, l) call check (size (g, 2), 5, l) call check (size (g), 25, l) call check (size (h, 1), 5, l) call check (size (h, 2), 5, l) call check (size (h), 25, l) call check (size (i, 1), 3, l) call check (size (i, 2), 5, l) call check (size (i, 3), 7, l) call check (size (i), 105, l) call check (size (j, 1), 4, l) call check (size (j, 2), 5, l) call check (size (j, 3), 7, l) call check (size (j), 140, l) call check (size (k, 1), 5, l) call check (size (k, 2), 1, l) call check (size (k, 3), 3, l) call check (size (k), 15, l) !$omp end parallel if (l) STOP 1 end subroutine foo subroutine test character (len = 12) :: c character (len = 7) :: d integer, dimension (2, 3:5, 7) :: e integer, dimension (2, 3:7, 7) :: f character (len = 12), dimension (5, 3:7) :: g character (len = 7), dimension (5, 3:7) :: h real, dimension (3:5, 2:6, 1:7) :: i double precision, dimension (3:6, 2:6, 1:7) :: j integer, dimension (1:5, 7:7, 4:6) :: k integer :: p, q, r c = 'abcdefghijkl' d = 'ABCDEFG' forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 + p + q + 2 * r forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 + p + q + 2 * r forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = '0123456789AB' forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = '9876543210ZY' forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = '0123456' forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = '9876543' forall (p = 3:5, q = 2:6, r = 1:7) i(p, q, r) = 7.5 * p * q * r forall (p = 3:6, q = 2:6, r = 1:7) j(p, q, r) = 9.5 * p * q * r forall (p = 1:5, q = 7:7, r = 4:6) k(p, q, r) = 19 + p + q + 3 * r call foo (c, d, e, f, g, h, i, j, k, 7) end subroutine test end