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