Retro68/gcc/libgomp/testsuite/libgomp.fortran/task2.f90
Wolfgang Thaller aaf905ce07 add gcc 4.70
2012-03-28 01:13:14 +02:00

143 lines
4.8 KiB
Fortran

integer :: err
err = 0
!$omp parallel num_threads (4) default (none) shared (err)
!$omp single
call test
!$omp end single
!$omp end parallel
if (err.ne.0) call abort
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) = '///|||!'
!$omp task default (none) firstprivate (c, d, e, f, g, h, i, j, k) &
!$omp & firstprivate (s, t, u, v) private (l, p, q, r, w, x, y) shared (err)
l = .false.
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
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)
if (l) then
!$omp atomic
err = err + 1
end if
!$omp end task
c = ''
d = ''
e(:, :, :) = 199
f(:, :, :) = 198
g(:, :) = ''
h(:, :) = ''
i(:, :, :) = 7.0
j(:, :, :) = 8.0
k(:, :, :) = 9
s = ''
t(:, :, :) = 10
u(:, :, :) = 11
v(:, :) = ''
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