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