OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /openrisc/trunk/gnu-stable/gcc-4.5.1/libgomp/testsuite/libgomp.fortran
    from Rev 816 to Rev 826
    ↔ Reverse comparison
  •

Rev 816 → Rev 826

/pr25219.f90
0,0 → 1,15
! PR fortran/25219
 
implicit none
save
integer :: i, k
k = 3
!$omp parallel
!$omp do lastprivate (k)
do i = 1, 100
k = i
end do
!$omp end do
!$omp end parallel
if (k .ne. 100) call abort
end
/condinc1.f
0,0 → 1,7
! { dg-options "-fopenmp" }
program condinc1
logical l
l = .false.
!$ include 'condinc1.inc'
stop 2
end
/appendix-a/a.5.1.f90
0,0 → 1,8
! { dg-do run }
PROGRAM A5
INCLUDE "omp_lib.h" ! or USE OMP_LIB
CALL OMP_SET_DYNAMIC(.TRUE.)
!$OMP PARALLEL NUM_THREADS(10)
! do work here
!$OMP END PARALLEL
END PROGRAM A5
/appendix-a/a.21.1.f90
0,0 → 1,19
! { dg-do compile }
SUBROUTINE WORK(K)
INTEGER k
!$OMP ORDERED
WRITE(*,*) K
!$OMP END ORDERED
END SUBROUTINE WORK
SUBROUTINE SUBA21(LB, UB, STRIDE)
INTEGER LB, UB, STRIDE
INTEGER I
!$OMP PARALLEL DO ORDERED SCHEDULE(DYNAMIC)
DO I=LB,UB,STRIDE
CALL WORK(I)
END DO
!$OMP END PARALLEL DO
END SUBROUTINE SUBA21
PROGRAM A21
CALL SUBA21(1,100,5)
END PROGRAM A21
/appendix-a/a.40.1.f90
0,0 → 1,54
! { dg-do compile }
! { dg-options "-ffixed-form" }
MODULE DATA
USE OMP_LIB, ONLY: OMP_NEST_LOCK_KIND
TYPE LOCKED_PAIR
INTEGER A
INTEGER B
INTEGER (OMP_NEST_LOCK_KIND) LCK
END TYPE
END MODULE DATA
SUBROUTINE INCR_A(P, A)
! called only from INCR_PAIR, no need to lock
USE DATA
TYPE(LOCKED_PAIR) :: P
INTEGER A
P%A = P%A + A
END SUBROUTINE INCR_A
SUBROUTINE INCR_B(P, B)
! called from both INCR_PAIR and elsewhere,
! so we need a nestable lock
USE OMP_LIB ! or INCLUDE "omp_lib.h"
USE DATA
TYPE(LOCKED_PAIR) :: P
INTEGER B
CALL OMP_SET_NEST_LOCK(P%LCK)
P%B = P%B + B
CALL OMP_UNSET_NEST_LOCK(P%LCK)
END SUBROUTINE INCR_B
SUBROUTINE INCR_PAIR(P, A, B)
USE OMP_LIB ! or INCLUDE "omp_lib.h"
USE DATA
TYPE(LOCKED_PAIR) :: P
INTEGER A
INTEGER B
CALL OMP_SET_NEST_LOCK(P%LCK)
CALL INCR_A(P, A)
CALL INCR_B(P, B)
CALL OMP_UNSET_NEST_LOCK(P%LCK)
END SUBROUTINE INCR_PAIR
SUBROUTINE A40(P)
USE OMP_LIB ! or INCLUDE "omp_lib.h"
USE DATA
TYPE(LOCKED_PAIR) :: P
INTEGER WORK1, WORK2, WORK3
EXTERNAL WORK1, WORK2, WORK3
!$OMP PARALLEL SECTIONS
!$OMP SECTION
CALL INCR_PAIR(P, WORK1(), WORK2())
!$OMP SECTION
CALL INCR_B(P, WORK3())
!$OMP END PARALLEL SECTIONS
END SUBROUTINE A40
 
! { dg-final { cleanup-modules "data" } }
/appendix-a/a.15.1.f90
0,0 → 1,31
! { dg-do compile }
SUBROUTINE WORK(N)
INTEGER N
END SUBROUTINE WORK
SUBROUTINE SUB3(N)
INTEGER N
CALL WORK(N)
!$OMP BARRIER
CALL WORK(N)
END SUBROUTINE SUB3
SUBROUTINE SUB2(K)
INTEGER K
!$OMP PARALLEL SHARED(K)
CALL SUB3(K)
!$OMP END PARALLEL
END SUBROUTINE SUB2
SUBROUTINE SUB1(N)
INTEGER N
INTEGER I
!$OMP PARALLEL PRIVATE(I) SHARED(N)
!$OMP DO
DO I = 1, N
CALL SUB2(I)
END DO
!$OMP END PARALLEL
END SUBROUTINE SUB1
PROGRAM A15
CALL SUB1(2)
CALL SUB2(2)
CALL SUB3(2)
END PROGRAM A15
/appendix-a/a.16.1.f90
0,0 → 1,41
! { dg-do run }
REAL FUNCTION WORK1(I)
INTEGER I
WORK1 = 1.0 * I
RETURN
END FUNCTION WORK1
 
REAL FUNCTION WORK2(I)
INTEGER I
WORK2 = 2.0 * I
RETURN
END FUNCTION WORK2
 
SUBROUTINE SUBA16(X, Y, INDEX, N)
REAL X(*), Y(*)
INTEGER INDEX(*), N
INTEGER I
!$OMP PARALLEL DO SHARED(X, Y, INDEX, N)
DO I=1,N
!$OMP ATOMIC
X(INDEX(I)) = X(INDEX(I)) + WORK1(I)
Y(I) = Y(I) + WORK2(I)
ENDDO
END SUBROUTINE SUBA16
 
PROGRAM A16
REAL X(1000), Y(10000)
INTEGER INDEX(10000)
INTEGER I
DO I=1,10000
INDEX(I) = MOD(I, 1000) + 1
Y(I) = 0.0
ENDDO
DO I = 1,1000
X(I) = 0.0
ENDDO
CALL SUBA16(X, Y, INDEX, 10000)
DO I = 1,10
PRINT *, "X(", I, ") = ", X(I), ", Y(", I, ") = ", Y(I)
ENDDO
END PROGRAM A16
/appendix-a/a.31.4.f90
0,0 → 1,14
! { dg-do run }
MODULE M
INTRINSIC MAX
END MODULE M
PROGRAM A31_4
USE M, REN => MAX
N=0
!$OMP PARALLEL DO REDUCTION(REN: N) ! still does MAX
DO I = 1, 100
N = MAX(N,I)
END DO
END PROGRAM A31_4
 
! { dg-final { cleanup-modules "m" } }
/appendix-a/a.33.3.f90
0,0 → 1,10
! { dg-do compile }
 
FUNCTION NEW_LOCK()
USE OMP_LIB ! or INCLUDE "omp_lib.h"
INTEGER(OMP_LOCK_KIND), POINTER :: NEW_LOCK
!$OMP SINGLE
ALLOCATE(NEW_LOCK)
CALL OMP_INIT_LOCK(NEW_LOCK)
!$OMP END SINGLE COPYPRIVATE(NEW_LOCK)
END FUNCTION NEW_LOCK
/appendix-a/a.31.5.f90
0,0 → 1,16
! { dg-do run }
MODULE MOD
INTRINSIC MAX, MIN
END MODULE MOD
PROGRAM A31_5
USE MOD, MIN=>MAX, MAX=>MIN
REAL :: R
R = -HUGE(0.0)
!$OMP PARALLEL DO REDUCTION(MIN: R) ! still does MAX
DO I = 1, 1000
R = MIN(R, SIN(REAL(I)))
END DO
PRINT *, R
END PROGRAM A31_5
 
! { dg-final { cleanup-modules "mod" } }
/appendix-a/a.26.1.f90
0,0 → 1,11
! { dg-do run }
PROGRAM A26
INTEGER I, J
I=1
J=2
!$OMP PARALLEL PRIVATE(I) FIRSTPRIVATE(J)
I=3
J=J+2
!$OMP END PARALLEL
PRINT *, I, J ! I and J are undefined
END PROGRAM A26
/appendix-a/a.18.1.f90
0,0 → 1,59
! { dg-do run }
! { dg-options "-ffixed-form" }
REAL FUNCTION FN1(I)
INTEGER I
FN1 = I * 2.0
RETURN
END FUNCTION FN1
 
REAL FUNCTION FN2(A, B)
REAL A, B
FN2 = A + B
RETURN
END FUNCTION FN2
 
PROGRAM A18
INCLUDE "omp_lib.h" ! or USE OMP_LIB
INTEGER ISYNC(256)
REAL WORK(256)
REAL RESULT(256)
INTEGER IAM, NEIGHBOR
!$OMP PARALLEL PRIVATE(IAM, NEIGHBOR) SHARED(WORK, ISYNC) NUM_THREADS(4)
IAM = OMP_GET_THREAD_NUM() + 1
ISYNC(IAM) = 0
!$OMP BARRIER
! Do computation into my portion of work array
WORK(IAM) = FN1(IAM)
! Announce that I am done with my work.
! The first flush ensures that my work is made visible before
! synch. The second flush ensures that synch is made visible.
!$OMP FLUSH(WORK,ISYNC)
ISYNC(IAM) = 1
!$OMP FLUSH(ISYNC)
 
! Wait until neighbor is done. The first flush ensures that
! synch is read from memory, rather than from the temporary
! view of memory. The second flush ensures that work is read
! from memory, and is done so after the while loop exits.
IF (IAM .EQ. 1) THEN
NEIGHBOR = OMP_GET_NUM_THREADS()
ELSE
NEIGHBOR = IAM - 1
ENDIF
DO WHILE (ISYNC(NEIGHBOR) .EQ. 0)
!$OMP FLUSH(ISYNC)
END DO
!$OMP FLUSH(WORK, ISYNC)
RESULT(IAM) = FN2(WORK(NEIGHBOR), WORK(IAM))
!$OMP END PARALLEL
DO I=1,4
IF (I .EQ. 1) THEN
NEIGHBOR = 4
ELSE
NEIGHBOR = I - 1
ENDIF
IF (RESULT(I) .NE. I * 2 + NEIGHBOR * 2) THEN
CALL ABORT
ENDIF
ENDDO
END PROGRAM A18
/appendix-a/a.19.1.f90
0,0 → 1,60
! { dg-do run }
SUBROUTINE F1(Q)
COMMON /DATA/ P, X
INTEGER, TARGET :: X
INTEGER, POINTER :: P
INTEGER Q
Q=1
!$OMP FLUSH
! X, P and Q are flushed
! because they are shared and accessible
END SUBROUTINE F1
SUBROUTINE F2(Q)
COMMON /DATA/ P, X
INTEGER, TARGET :: X
INTEGER, POINTER :: P
INTEGER Q
!$OMP BARRIER
Q=2
!$OMP BARRIER
! a barrier implies a flush
! X, P and Q are flushed
! because they are shared and accessible
END SUBROUTINE F2
 
INTEGER FUNCTION G(N)
COMMON /DATA/ P, X
INTEGER, TARGET :: X
INTEGER, POINTER :: P
INTEGER N
INTEGER I, J, SUM
I=1
SUM = 0
P=1
!$OMP PARALLEL REDUCTION(+: SUM) NUM_THREADS(2)
CALL F1(J)
! I, N and SUM were not flushed
! because they were not accessible in F1
! J was flushed because it was accessible
SUM = SUM + J
CALL F2(J)
! I, N, and SUM were not flushed
! because they were not accessible in f2
! J was flushed because it was accessible
SUM = SUM + I + J + P + N
!$OMP END PARALLEL
G = SUM
END FUNCTION G
 
PROGRAM A19
COMMON /DATA/ P, X
INTEGER, TARGET :: X
INTEGER, POINTER :: P
INTEGER RESULT, G
P => X
RESULT = G(10)
PRINT *, RESULT
IF (RESULT .NE. 30) THEN
CALL ABORT
ENDIF
END PROGRAM A19
/appendix-a/a.22.7.f90
0,0 → 1,33
! { dg-do run }
! { dg-require-effective-target tls_runtime }
 
PROGRAM A22_7_GOOD
INTEGER, ALLOCATABLE, SAVE :: A(:)
INTEGER, POINTER, SAVE :: PTR
INTEGER, SAVE :: I
INTEGER, TARGET :: TARG
LOGICAL :: FIRSTIN = .TRUE.
!$OMP THREADPRIVATE(A, I, PTR)
ALLOCATE (A(3))
A = (/1,2,3/)
PTR => TARG
I=5
!$OMP PARALLEL COPYIN(I, PTR)
!$OMP CRITICAL
IF (FIRSTIN) THEN
TARG = 4 ! Update target of ptr
I = I + 10
IF (ALLOCATED(A)) A = A + 10
FIRSTIN = .FALSE.
END IF
IF (ALLOCATED(A)) THEN
PRINT *, "a = ", A
ELSE
PRINT *, "A is not allocated"
END IF
PRINT *, "ptr = ", PTR
PRINT *, "i = ", I
PRINT *
!$OMP END CRITICAL
!$OMP END PARALLEL
END PROGRAM A22_7_GOOD
/appendix-a/a.28.1.f90
0,0 → 1,14
! { dg-do run }
 
SUBROUTINE SUB()
COMMON /BLOCK/ X
PRINT *,X ! X is undefined
END SUBROUTINE SUB
PROGRAM A28_1
COMMON /BLOCK/ X
X = 1.0
!$OMP PARALLEL PRIVATE (X)
X = 2.0
CALL SUB()
!$OMP END PARALLEL
END PROGRAM A28_1
/appendix-a/a.38.1.f90
0,0 → 1,12
! { dg-do compile }
 
FUNCTION NEW_LOCKS()
USE OMP_LIB ! or INCLUDE "omp_lib.h"
INTEGER(OMP_LOCK_KIND), DIMENSION(1000) :: NEW_LOCKS
INTEGER I
!$OMP PARALLEL DO PRIVATE(I)
DO I=1,1000
CALL OMP_INIT_LOCK(NEW_LOCKS(I))
END DO
!$OMP END PARALLEL DO
END FUNCTION NEW_LOCKS
/appendix-a/a.22.8.f90
0,0 → 1,26
! { dg-do run }
! { dg-require-effective-target tls_runtime }
MODULE A22_MODULE8
REAL, POINTER :: WORK(:)
SAVE WORK
!$OMP THREADPRIVATE(WORK)
END MODULE A22_MODULE8
SUBROUTINE SUB1(N)
USE A22_MODULE8
!$OMP PARALLEL PRIVATE(THE_SUM)
ALLOCATE(WORK(N))
CALL SUB2(THE_SUM)
WRITE(*,*)THE_SUM
!$OMP END PARALLEL
END SUBROUTINE SUB1
SUBROUTINE SUB2(THE_SUM)
USE A22_MODULE8
WORK(:) = 10
THE_SUM=SUM(WORK)
END SUBROUTINE SUB2
PROGRAM A22_8_GOOD
N = 10
CALL SUB1(N)
END PROGRAM A22_8_GOOD
 
! { dg-final { cleanup-modules "a22_module8" } }
/appendix-a/a.28.2.f90
0,0 → 1,16
! { dg-do run }
 
PROGRAM A28_2
COMMON /BLOCK2/ X
X = 1.0
!$OMP PARALLEL PRIVATE (X)
X = 2.0
CALL SUB()
!$OMP END PARALLEL
CONTAINS
SUBROUTINE SUB()
COMMON /BLOCK2/ Y
PRINT *,X ! X is undefined
PRINT *,Y ! Y is undefined
END SUBROUTINE SUB
END PROGRAM A28_2
/appendix-a/a.28.3.f90
0,0 → 1,11
! { dg-do run }
 
PROGRAM A28_3
EQUIVALENCE (X,Y)
X = 1.0
!$OMP PARALLEL PRIVATE(X)
PRINT *,Y ! Y is undefined
Y = 10
PRINT *,X ! X is undefined
!$OMP END PARALLEL
END PROGRAM A28_3
/appendix-a/a.39.1.f90
0,0 → 1,26
! { dg-do run }
 
SUBROUTINE SKIP(ID)
END SUBROUTINE SKIP
SUBROUTINE WORK(ID)
END SUBROUTINE WORK
PROGRAM A39
INCLUDE "omp_lib.h" ! or USE OMP_LIB
INTEGER(OMP_LOCK_KIND) LCK
INTEGER ID
CALL OMP_INIT_LOCK(LCK)
!$OMP PARALLEL SHARED(LCK) PRIVATE(ID)
ID = OMP_GET_THREAD_NUM()
CALL OMP_SET_LOCK(LCK)
PRINT *, "My thread id is ", ID
CALL OMP_UNSET_LOCK(LCK)
DO WHILE (.NOT. OMP_TEST_LOCK(LCK))
CALL SKIP(ID) ! We do not yet have the lock
! so we must do something else
END DO
CALL WORK(ID) ! We now have the lock
! and can do the work
CALL OMP_UNSET_LOCK( LCK )
!$OMP END PARALLEL
CALL OMP_DESTROY_LOCK( LCK )
END PROGRAM A39
/appendix-a/a.28.4.f90
0,0 → 1,24
! { dg-do run }
 
PROGRAM A28_4
INTEGER I, J
INTEGER A(100), B(100)
EQUIVALENCE (A(51), B(1))
!$OMP PARALLEL DO DEFAULT(PRIVATE) PRIVATE(I,J) LASTPRIVATE(A)
DO I=1,100
DO J=1,100
B(J) = J - 1
ENDDO
DO J=1,100
A(J) = J ! B becomes undefined at this point
ENDDO
DO J=1,50
B(J) = B(J) + 1 ! B is undefined
! A becomes undefined at this point
ENDDO
ENDDO
!$OMP END PARALLEL DO ! The LASTPRIVATE write for A has
! undefined results
PRINT *, B ! B is undefined since the LASTPRIVATE
! write of A was not defined
END PROGRAM A28_4
/appendix-a/a.28.5.f90
0,0 → 1,29
! { dg-do compile }
 
SUBROUTINE SUB1(X)
DIMENSION X(10)
! This use of X does not conform to the
! specification. It would be legal Fortran 90,
! but the OpenMP private directive allows the
! compiler to break the sequence association that
! A had with the rest of the common block.
FORALL (I = 1:10) X(I) = I
END SUBROUTINE SUB1
PROGRAM A28_5
COMMON /BLOCK5/ A
DIMENSION B(10)
EQUIVALENCE (A,B(1))
! the common block has to be at least 10 words
A=0
!$OMP PARALLEL PRIVATE(/BLOCK5/)
! Without the private clause,
! we would be passing a member of a sequence
! that is at least ten elements long.
! With the private clause, A may no longer be
! sequence-associated.
CALL SUB1(A)
!$OMP MASTER
PRINT *, A
!$OMP END MASTER
!$OMP END PARALLEL
END PROGRAM A28_5
/appendix-a/a.2.1.f90
0,0 → 1,22
! { dg-do run }
PROGRAM A2
INCLUDE "omp_lib.h" ! or USE OMP_LIB
INTEGER X
X=2
!$OMP PARALLEL NUM_THREADS(2) SHARED(X)
IF (OMP_GET_THREAD_NUM() .EQ. 0) THEN
X=5
ELSE
! PRINT 1: The following read of x has a race
PRINT *,"1: THREAD# ", OMP_GET_THREAD_NUM(), "X = ", X
ENDIF
!$OMP BARRIER
IF (OMP_GET_THREAD_NUM() .EQ. 0) THEN
! PRINT 2
PRINT *,"2: THREAD# ", OMP_GET_THREAD_NUM(), "X = ", X
ELSE
! PRINT 3
PRINT *,"3: THREAD# ", OMP_GET_THREAD_NUM(), "X = ", X
ENDIF
!$OMP END PARALLEL
END PROGRAM A2
/appendix-a/a.3.1.f90
0,0 → 1,6
! { dg-do run }
! { dg-options "-ffixed-form" }
PROGRAM A3
!234567890
!$ PRINT *, "Compiled by an OpenMP-compliant implementation."
END PROGRAM A3
/appendix-a/a10.1.f90
0,0 → 1,20
! { dg-do run }
SUBROUTINE WORK1()
END SUBROUTINE WORK1
SUBROUTINE WORK2()
END SUBROUTINE WORK2
PROGRAM A10
!$OMP PARALLEL
!$OMP SINGLE
print *, "Beginning work1."
!$OMP END SINGLE
CALL WORK1()
!$OMP SINGLE
print *, "Finishing work1."
!$OMP END SINGLE
!$OMP SINGLE
print *, "Finished work1 and beginning work2."
!$OMP END SINGLE NOWAIT
CALL WORK2()
!$OMP END PARALLEL
END PROGRAM A10
/appendix-a/a.4.1.f90
0,0 → 1,29
! { dg-do run }
SUBROUTINE SUBDOMAIN(X, ISTART, IPOINTS)
INTEGER ISTART, IPOINTS
REAL X(*)
INTEGER I
DO 100 I=1,IPOINTS
X(ISTART+I) = 123.456
100 CONTINUE
END SUBROUTINE SUBDOMAIN
SUBROUTINE SUB(X, NPOINTS)
INCLUDE "omp_lib.h" ! or USE OMP_LIB
REAL X(*)
INTEGER NPOINTS
INTEGER IAM, NT, IPOINTS, ISTART
!$OMP PARALLEL DEFAULT(PRIVATE) SHARED(X,NPOINTS)
IAM = OMP_GET_THREAD_NUM()
NT = OMP_GET_NUM_THREADS()
IPOINTS = NPOINTS/NT
ISTART = IAM * IPOINTS
IF (IAM .EQ. NT-1) THEN
IPOINTS = NPOINTS - ISTART
ENDIF
CALL SUBDOMAIN(X,ISTART,IPOINTS)
!$OMP END PARALLEL
END SUBROUTINE SUB
PROGRAM A4
REAL ARRAY(10000)
CALL SUB(ARRAY, 10000)
END PROGRAM A4
/pr27395-1.f90
0,0 → 1,31
! PR fortran/27395
! { dg-do run }
 
program pr27395_1
implicit none
integer, parameter :: n=10,m=1001
integer :: i
integer, dimension(n) :: sumarray
call foo(n,m,sumarray)
do i=1,n
if (sumarray(i).ne.m*i) call abort
end do
end program pr27395_1
 
subroutine foo(n,m,sumarray)
use omp_lib, only : omp_get_thread_num
implicit none
integer, intent(in) :: n,m
integer, dimension(n), intent(out) :: sumarray
integer :: i,j
sumarray(:)=0
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(4)
!$OMP DO PRIVATE(j,i), REDUCTION(+:sumarray)
do j=1,m
do i=1,n
sumarray(i)=sumarray(i)+i
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end subroutine foo
/pr27395-2.f90
0,0 → 1,30
! PR fortran/27395
! { dg-do run }
 
program pr27395_2
implicit none
integer, parameter :: n=10,m=1001
integer :: i
call foo(n,m)
end program pr27395_2
 
subroutine foo(n,m)
use omp_lib, only : omp_get_thread_num
implicit none
integer, intent(in) :: n,m
integer :: i,j
integer, dimension(n) :: sumarray
sumarray(:)=0
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(4)
!$OMP DO PRIVATE(j,i), REDUCTION(+:sumarray)
do j=1,m
do i=1,n
sumarray(i)=sumarray(i)+i
end do
end do
!$OMP END DO
!$OMP END PARALLEL
do i=1,n
if (sumarray(i).ne.m*i) call abort
end do
end subroutine foo
/stack.f90
0,0 → 1,21
! { dg-do run }
program stack
implicit none
integer id
integer ilocs(2)
integer omp_get_thread_num, foo
call omp_set_num_threads (2)
!$omp parallel private (id)
id = omp_get_thread_num() + 1
ilocs(id) = foo()
!$omp end parallel
! Check that the two threads are not sharing a location for
! the array x in foo()
if (ilocs(1) .eq. ilocs(2)) call abort
end program stack
 
integer function foo ()
implicit none
real x(100,100)
foo = loc(x)
end function foo
/crayptr1.f90
0,0 → 1,46
! { dg-do run }
! { dg-options "-fopenmp -fcray-pointer" }
 
use omp_lib
integer :: a, b, c, p
logical :: l
pointer (ip, p)
a = 1
b = 2
c = 3
l = .false.
ip = loc (a)
 
!$omp parallel num_threads (2) reduction (.or.:l)
l = p .ne. 1
!$omp barrier
!$omp master
ip = loc (b)
!$omp end master
!$omp barrier
l = l .or. p .ne. 2
!$omp barrier
if (omp_get_thread_num () .eq. 1 .or. omp_get_num_threads () .lt. 2) &
ip = loc (c)
!$omp barrier
l = l .or. p .ne. 3
!$omp end parallel
 
if (l) call abort
 
l = .false.
!$omp parallel num_threads (2) reduction (.or.:l) default (private)
ip = loc (a)
a = 3 * omp_get_thread_num () + 4
b = a + 1
c = a + 2
l = p .ne. 3 * omp_get_thread_num () + 4
ip = loc (c)
l = l .or. p .ne. 3 * omp_get_thread_num () + 6
ip = loc (b)
l = l .or. p .ne. 3 * omp_get_thread_num () + 5
!$omp end parallel
 
if (l) call abort
 
end
/crayptr2.f90
0,0 → 1,31
! { dg-do run }
! { dg-options "-fopenmp -fcray-pointer" }
! { dg-require-effective-target tls_runtime }
 
use omp_lib
integer :: a, b, c, d, p
logical :: l
pointer (ip, p)
save ip
!$omp threadprivate (ip)
a = 1
b = 2
c = 3
l = .false.
!$omp parallel num_threads (3) reduction (.or.:l)
if (omp_get_thread_num () .eq. 0) then
ip = loc (a)
elseif (omp_get_thread_num () .eq. 1) then
ip = loc (b)
else
ip = loc (c)
end if
l = p .ne. omp_get_thread_num () + 1
!$omp single
d = omp_get_thread_num ()
!$omp end single copyprivate (d, ip)
l = l .or. (p .ne. d + 1)
!$omp end parallel
 
if (l) call abort
end
/omp_parse1.f90
0,0 → 1,185
! { dg-do run }
use omp_lib
call test_parallel
call test_do
call test_sections
call test_single
 
contains
subroutine test_parallel
integer :: a, b, c, e, f, g, i, j
integer, dimension (20) :: d
logical :: h
a = 6
b = 8
c = 11
d(:) = -1
e = 13
f = 24
g = 27
h = .false.
i = 1
j = 16
!$omp para&
!$omp&llel &
!$omp if (a .eq. 6) private (b, c) shared (d) private (e) &
!$omp firstprivate(f) num_threads (a - 1) first&
!$ompprivate(g)default (shared) reduction (.or. : h) &
!$omp reduction(*:i)
if (i .ne. 1) h = .true.
i = 2
if (f .ne. 24) h = .true.
if (g .ne. 27) h = .true.
e = 7
b = omp_get_thread_num ()
if (b .eq. 0) j = 24
f = b
g = f
c = omp_get_num_threads ()
if (c .gt. a - 1 .or. c .le. 0) h = .true.
if (b .ge. c) h = .true.
d(b + 1) = c
if (f .ne. g .or. f .ne. b) h = .true.
!$omp endparallel
if (h) call abort
if (a .ne. 6) call abort
if (j .ne. 24) call abort
if (d(1) .eq. -1) call abort
e = 1
do g = 1, d(1)
if (d(g) .ne. d(1)) call abort
e = e * 2
end do
if (e .ne. i) call abort
end subroutine test_parallel
 
subroutine test_do_orphan
integer :: k, l
!$omp parallel do private (l)
do 600 k = 1, 16, 2
600 l = k
end subroutine test_do_orphan
 
subroutine test_do
integer :: i, j, k, l, n
integer, dimension (64) :: d
logical :: m
 
j = 16
d(:) = -1
m = .true.
n = 24
!$omp parallel num_threads (4) shared (i, k, d) private (l) &
!$omp&reduction (.and. : m)
if (omp_get_thread_num () .eq. 0) then
k = omp_get_num_threads ()
end if
call test_do_orphan
!$omp do schedule (static) firstprivate (n)
do 200 i = 1, j
if (i .eq. 1 .and. n .ne. 24) call abort
n = i
200 d(n) = omp_get_thread_num ()
!$omp enddo nowait
 
!$omp do lastprivate (i) schedule (static, 5)
do 201 i = j + 1, 2 * j
201 d(i) = omp_get_thread_num () + 1024
! Implied omp end do here
 
if (i .ne. 33) m = .false.
 
!$omp do private (j) schedule (dynamic)
do i = 33, 48
d(i) = omp_get_thread_num () + 2048
end do
!$omp end do nowait
 
!$omp do schedule (runtime)
do i = 49, 4 * j
d(i) = omp_get_thread_num () + 4096
end do
! Implied omp end do here
!$omp end parallel
if (.not. m) call abort
 
j = 0
do i = 1, 64
if (d(i) .lt. j .or. d(i) .ge. j + k) call abort
if (i .eq. 16) j = 1024
if (i .eq. 32) j = 2048
if (i .eq. 48) j = 4096
end do
end subroutine test_do
 
subroutine test_sections
integer :: i, j, k, l, m, n
i = 9
j = 10
k = 11
l = 0
m = 0
n = 30
call omp_set_dynamic (.false.)
call omp_set_num_threads (4)
!$omp parallel num_threads (4)
!$omp sections private (i) firstprivate (j, k) lastprivate (j) &
!$omp& reduction (+ : l, m)
!$omp section
i = 24
if (j .ne. 10 .or. k .ne. 11 .or. m .ne. 0) l = 1
m = m + 4
!$omp section
i = 25
if (j .ne. 10 .or. k .ne. 11) l = 1
m = m + 6
!$omp section
i = 26
if (j .ne. 10 .or. k .ne. 11) l = 1
m = m + 8
!$omp section
i = 27
if (j .ne. 10 .or. k .ne. 11) l = 1
m = m + 10
j = 271
!$omp end sections nowait
!$omp sections lastprivate (n)
!$omp section
n = 6
!$omp section
n = 7
!$omp endsections
!$omp end parallel
if (j .ne. 271 .or. l .ne. 0) call abort
if (m .ne. 4 + 6 + 8 + 10) call abort
if (n .ne. 7) call abort
end subroutine test_sections
 
subroutine test_single
integer :: i, j, k, l
logical :: m
i = 200
j = 300
k = 400
l = 500
m = .false.
!$omp parallel num_threads (4), private (i, j), reduction (.or. : m)
i = omp_get_thread_num ()
j = omp_get_thread_num ()
!$omp single private (k)
k = 64
!$omp end single nowait
!$omp single private (k) firstprivate (l)
if (i .ne. omp_get_thread_num () .or. i .ne. j) then
j = -1
else
j = -2
end if
if (l .ne. 500) j = -1
l = 265
!$omp end single copyprivate (j)
if (i .ne. omp_get_thread_num () .or. j .ne. -2) m = .true.
!$omp endparallel
if (m) call abort
end subroutine test_single
end
/omp_parse2.f90
0,0 → 1,102
! { dg-do run }
use omp_lib
call test_master
call test_critical
call test_barrier
call test_atomic
 
contains
subroutine test_master
logical :: i, j
i = .false.
j = .false.
!$omp parallel num_threads (4)
!$omp master
i = .true.
j = omp_get_thread_num () .eq. 0
!$omp endmaster
!$omp end parallel
if (.not. (i .or. j)) call abort
end subroutine test_master
 
subroutine test_critical_1 (i, j)
integer :: i, j
!$omp critical(critical_foo)
i = i + 1
!$omp end critical (critical_foo)
!$omp critical
j = j + 1
!$omp end critical
end subroutine test_critical_1
 
subroutine test_critical
integer :: i, j, n
n = -1
i = 0
j = 0
!$omp parallel num_threads (4)
if (omp_get_thread_num () .eq. 0) n = omp_get_num_threads ()
call test_critical_1 (i, j)
call test_critical_1 (i, j)
!$omp critical
j = j + 1
!$omp end critical
!$omp critical (critical_foo)
i = i + 1
!$omp endcritical (critical_foo)
!$omp end parallel
if (n .lt. 1 .or. i .ne. n * 3 .or. j .ne. n * 3) call abort
end subroutine test_critical
 
subroutine test_barrier
integer :: i
logical :: j
i = 23
j = .false.
!$omp parallel num_threads (4)
if (omp_get_thread_num () .eq. 0) i = 5
!$omp flush (i)
!$omp barrier
if (i .ne. 5) then
!$omp atomic
j = j .or. .true.
end if
!$omp end parallel
if (i .ne. 5 .or. j) call abort
end subroutine test_barrier
 
subroutine test_atomic
integer :: a, b, c, d, e, f, g
a = 0
b = 1
c = 0
d = 1024
e = 1024
f = -1
g = -1
!$omp parallel num_threads (8)
!$omp atomic
a = a + 2 + 4
!$omp atomic
b = 3 * b
!$omp atomic
c = 8 - c
!$omp atomic
d = d / 2
!$omp atomic
e = min (e, omp_get_thread_num ())
!$omp atomic
f = max (omp_get_thread_num (), f)
if (omp_get_thread_num () .eq. 0) g = omp_get_num_threads ()
!$omp end parallel
if (g .le. 0 .or. g .gt. 8) call abort
if (a .ne. 6 * g .or. b .ne. 3 ** g) call abort
if (iand (g, 1) .eq. 1) then
if (c .ne. 8) call abort
else if (c .ne. 0) then
call abort
end if
if (d .ne. 1024 / (2 ** g)) call abort
if (e .ne. 0 .or. f .ne. g - 1) call abort
end subroutine test_atomic
end
/omp_parse3.f90
0,0 → 1,96
! { dg-do run }
! { dg-require-effective-target tls_runtime }
use omp_lib
common /tlsblock/ x, y
integer :: x, y, z
save z
!$omp threadprivate (/tlsblock/, z)
 
call test_flush
call test_ordered
call test_threadprivate
 
contains
subroutine test_flush
integer :: i, j
i = 0
j = 0
!$omp parallel num_threads (4)
if (omp_get_thread_num () .eq. 0) i = omp_get_num_threads ()
if (omp_get_thread_num () .eq. 0) j = j + 1
!$omp flush (i, j)
!$omp barrier
if (omp_get_thread_num () .eq. 1) j = j + 2
!$omp flush
!$omp barrier
if (omp_get_thread_num () .eq. 2) j = j + 3
!$omp flush (i)
!$omp flush (j)
!$omp barrier
if (omp_get_thread_num () .eq. 3) j = j + 4
!$omp end parallel
end subroutine test_flush
 
subroutine test_ordered
integer :: i, j
integer, dimension (100) :: d
d(:) = -1
!$omp parallel do ordered schedule (dynamic) num_threads (4)
do i = 1, 100, 5
!$omp ordered
d(i) = i
!$omp end ordered
end do
j = 1
do 100 i = 1, 100
if (i .eq. j) then
if (d(i) .ne. i) call abort
j = i + 5
else
if (d(i) .ne. -1) call abort
end if
100 d(i) = -1
end subroutine test_ordered
 
subroutine test_threadprivate
common /tlsblock/ x, y
!$omp threadprivate (/tlsblock/)
integer :: i, j, x, y
logical :: m, n
call omp_set_num_threads (4)
call omp_set_dynamic (.false.)
i = -1
x = 6
y = 7
z = 8
n = .false.
m = .false.
!$omp parallel copyin (/tlsblock/, z) reduction (.or.:m) &
!$omp& num_threads (4)
if (omp_get_thread_num () .eq. 0) i = omp_get_num_threads ()
if (x .ne. 6 .or. y .ne. 7 .or. z .ne. 8) call abort
x = omp_get_thread_num ()
y = omp_get_thread_num () + 1024
z = omp_get_thread_num () + 4096
!$omp end parallel
if (x .ne. 0 .or. y .ne. 1024 .or. z .ne. 4096) call abort
!$omp parallel num_threads (4), private (j) reduction (.or.:n)
if (omp_get_num_threads () .eq. i) then
j = omp_get_thread_num ()
if (x .ne. j .or. y .ne. j + 1024 .or. z .ne. j + 4096) &
& call abort
end if
!$omp end parallel
m = m .or. n
n = .false.
!$omp parallel num_threads (4), copyin (z) reduction (.or. : n) &
!$omp&private (j)
if (z .ne. 4096) n = .true.
if (omp_get_num_threads () .eq. i) then
j = omp_get_thread_num ()
if (x .ne. j .or. y .ne. j + 1024) call abort
end if
!$omp end parallel
if (m .or. n) call abort
end subroutine test_threadprivate
end
/condinc1.inc
0,0 → 1,2
if (l) stop 3
return
/omp_parse4.f90
0,0 → 1,72
! { dg-do run }
!$ use omp_lib
call test_workshare
 
contains
subroutine test_workshare
integer :: i, j, k, l, m
double precision, dimension (64) :: d, e
integer, dimension (10) :: f, g
integer, dimension (16, 16) :: a, b, c
integer, dimension (16) :: n
d(:) = 1
e = 7
f = 10
l = 256
m = 512
g(1:3) = -1
g(4:6) = 0
g(7:8) = 5
g(9:10) = 10
forall (i = 1:16, j = 1:16) a (i, j) = i * 16 + j
forall (j = 1:16) n (j) = j
!$omp parallel num_threads (4) private (j, k)
!$omp barrier
!$omp workshare
i = 6
e(:) = d(:)
where (g .lt. 0)
f = 100
elsewhere (g .eq. 0)
f = 200 + f
elsewhere
where (g .gt. 6) f = f + sum (g)
f = 300 + f
end where
where (f .gt. 210) g = 0
!$omp end workshare nowait
!$omp workshare
forall (j = 1:16, k = 1:16) b (k, j) = a (j, k)
forall (k = 1:16) c (k, 1:16) = a (1:16, k)
forall (j = 2:16, n (17 - j) / 4 * 4 .ne. n (17 - j))
n (j) = n (j - 1) * n (j)
end forall
!$omp endworkshare
!$omp workshare
!$omp atomic
i = i + 8 + 6
!$omp critical
!$omp critical (critical_foox)
l = 128
!$omp end critical (critical_foox)
!$omp endcritical
!$omp parallel num_threads (2)
!$ if (omp_get_thread_num () .eq. 0) m = omp_get_num_threads ()
!$omp atomic
l = 1 + l
!$omp end parallel
!$omp end workshare
!$omp end parallel
 
if (any (f .ne. (/100, 100, 100, 210, 210, 210, 310, 310, 337, 337/))) &
& call abort
if (any (g .ne. (/-1, -1, -1, 0, 0, 0, 0, 0, 0, 0/))) call abort
if (i .ne. 20) call abort
!$ if (l .ne. 128 + m) call abort
if (any (d .ne. 1 .or. e .ne. 1)) call abort
if (any (b .ne. transpose (a))) call abort
if (any (c .ne. b)) call abort
if (any (n .ne. (/1, 2, 6, 12, 5, 30, 42, 56, 9, 90, &
& 110, 132, 13, 182, 210, 240/))) call abort
end subroutine test_workshare
end
/reduction1.f90
0,0 → 1,181
! { dg-do run }
!$ use omp_lib
 
integer :: i, ia (6), n, cnt
real :: r, ra (4)
double precision :: d, da (5)
complex :: c, ca (3)
logical :: v
 
i = 1
ia = 2
r = 3
ra = 4
d = 5.5
da = 6.5
c = cmplx (7.5, 1.5)
ca = cmplx (8.5, -3.0)
v = .false.
cnt = -1
 
!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
!$omp & reduction (+:i, ia, r, ra, d, da, c, ca)
!$ if (i .ne. 0 .or. any (ia .ne. 0)) v = .true.
!$ if (r .ne. 0 .or. any (ra .ne. 0)) v = .true.
!$ if (d .ne. 0 .or. any (da .ne. 0)) v = .true.
!$ if (c .ne. cmplx (0) .or. any (ca .ne. cmplx (0))) v = .true.
n = omp_get_thread_num ()
if (n .eq. 0) then
cnt = omp_get_num_threads ()
i = 4
ia(3:5) = -2
r = 5
ra(1:2) = 6.5
d = -2.5
da(2:4) = 8.5
c = cmplx (2.5, -3.5)
ca(1) = cmplx (4.5, 5)
else if (n .eq. 1) then
i = 2
ia(4:6) = 5
r = 1
ra(2:4) = -1.5
d = 8.5
da(1:3) = 2.5
c = cmplx (0.5, -3)
ca(2:3) = cmplx (-1, 6)
else
i = 1
ia = 1
r = -1
ra = -1
d = 1
da = -1
c = 1
ca = cmplx (-1, 0)
end if
!$omp end parallel
if (v) call abort
if (cnt .eq. 3) then
if (i .ne. 8 .or. any (ia .ne. (/3, 3, 1, 6, 6, 8/))) call abort
if (r .ne. 8 .or. any (ra .ne. (/9.5, 8.0, 1.5, 1.5/))) call abort
if (d .ne. 12.5 .or. any (da .ne. (/8.0, 16.5, 16.5, 14.0, 5.5/))) call abort
if (c .ne. cmplx (11.5, -5)) call abort
if (ca(1) .ne. cmplx (12, 2)) call abort
if (ca(2) .ne. cmplx (6.5, 3) .or. ca(2) .ne. ca(3)) call abort
end if
 
i = 1
ia = 2
r = 3
ra = 4
d = 5.5
da = 6.5
c = cmplx (7.5, 1.5)
ca = cmplx (8.5, -3.0)
v = .false.
cnt = -1
 
!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
!$omp & reduction (-:i, ia, r, ra, d, da, c, ca)
!$ if (i .ne. 0 .or. any (ia .ne. 0)) v = .true.
!$ if (r .ne. 0 .or. any (ra .ne. 0)) v = .true.
!$ if (d .ne. 0 .or. any (da .ne. 0)) v = .true.
!$ if (c .ne. cmplx (0) .or. any (ca .ne. cmplx (0))) v = .true.
n = omp_get_thread_num ()
if (n .eq. 0) then
cnt = omp_get_num_threads ()
i = 4
ia(3:5) = -2
r = 5
ra(1:2) = 6.5
d = -2.5
da(2:4) = 8.5
c = cmplx (2.5, -3.5)
ca(1) = cmplx (4.5, 5)
else if (n .eq. 1) then
i = 2
ia(4:6) = 5
r = 1
ra(2:4) = -1.5
d = 8.5
da(1:3) = 2.5
c = cmplx (0.5, -3)
ca(2:3) = cmplx (-1, 6)
else
i = 1
ia = 1
r = -1
ra = -1
d = 1
da = -1
c = 1
ca = cmplx (-1, 0)
end if
!$omp end parallel
if (v) call abort
if (cnt .eq. 3) then
if (i .ne. 8 .or. any (ia .ne. (/3, 3, 1, 6, 6, 8/))) call abort
if (r .ne. 8 .or. any (ra .ne. (/9.5, 8.0, 1.5, 1.5/))) call abort
if (d .ne. 12.5 .or. any (da .ne. (/8.0, 16.5, 16.5, 14.0, 5.5/))) call abort
if (c .ne. cmplx (11.5, -5)) call abort
if (ca(1) .ne. cmplx (12, 2)) call abort
if (ca(2) .ne. cmplx (6.5, 3) .or. ca(2) .ne. ca(3)) call abort
end if
 
i = 1
ia = 2
r = 4
ra = 8
d = 16
da = 32
c = 2
ca = cmplx (0, 2)
v = .false.
cnt = -1
 
!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
!$omp & reduction (*:i, ia, r, ra, d, da, c, ca)
!$ if (i .ne. 1 .or. any (ia .ne. 1)) v = .true.
!$ if (r .ne. 1 .or. any (ra .ne. 1)) v = .true.
!$ if (d .ne. 1 .or. any (da .ne. 1)) v = .true.
!$ if (c .ne. cmplx (1) .or. any (ca .ne. cmplx (1))) v = .true.
n = omp_get_thread_num ()
if (n .eq. 0) then
cnt = omp_get_num_threads ()
i = 3
ia(3:5) = 2
r = 0.5
ra(1:2) = 2
d = -1
da(2:4) = -2
c = 2.5
ca(1) = cmplx (-5, 0)
else if (n .eq. 1) then
i = 2
ia(4:6) = -2
r = 8
ra(2:4) = -0.5
da(1:3) = -1
c = -3
ca(2:3) = cmplx (0, -1)
else
ia = 2
r = 0.5
ra = 0.25
d = 2.5
da = -1
c = cmplx (0, -1)
ca = cmplx (-1, 0)
end if
!$omp end parallel
if (v) call abort
if (cnt .eq. 3) then
if (i .ne. 6 .or. any (ia .ne. (/4, 4, 8, -16, -16, -8/))) call abort
if (r .ne. 8 .or. any (ra .ne. (/4., -2., -1., -1./))) call abort
if (d .ne. -40 .or. any (da .ne. (/32., -64., -64., 64., -32./))) call abort
if (c .ne. cmplx (0, 15)) call abort
if (ca(1) .ne. cmplx (0, 10)) call abort
if (ca(2) .ne. cmplx (-2, 0) .or. ca(2) .ne. ca(3)) call abort
end if
end
/character1.f90
0,0 → 1,72
! { dg-do run }
!$ use omp_lib
 
character (len = 8) :: h, i
character (len = 4) :: j, k
h = '01234567'
i = 'ABCDEFGH'
j = 'IJKL'
k = 'MN'
call test (h, j)
contains
subroutine test (p, q)
character (len = 8) :: p
character (len = 4) :: q, r
character (len = 16) :: f
character (len = 32) :: g
integer, dimension (18) :: s
logical :: l
integer :: m
f = 'test16'
g = 'abcdefghijklmnopqrstuvwxyz'
r = ''
l = .false.
s = -6
!$omp parallel firstprivate (f, p, s) private (r, m) reduction (.or.:l) &
!$omp & num_threads (4)
m = omp_get_thread_num ()
if (any (s .ne. -6)) l = .true.
l = l .or. f .ne. 'test16' .or. p .ne. '01234567'
l = l .or. g .ne. 'abcdefghijklmnopqrstuvwxyz'
l = l .or. i .ne. 'ABCDEFGH' .or. q .ne. 'IJKL'
l = l .or. k .ne. 'MN'
!$omp barrier
if (m .eq. 0) then
f = 'ffffffff0'
g = 'xyz'
i = '123'
k = '9876'
p = '_abc'
q = '_def'
r = '1_23'
else if (m .eq. 1) then
f = '__'
p = 'xxx'
r = '7575'
else if (m .eq. 2) then
f = 'ZZ'
p = 'm2'
r = 'M2'
else if (m .eq. 3) then
f = 'YY'
p = 'm3'
r = 'M3'
end if
s = m
!$omp barrier
l = l .or. g .ne. 'xyz' .or. i .ne. '123' .or. k .ne. '9876'
l = l .or. q .ne. '_def'
if (any (s .ne. m)) l = .true.
if (m .eq. 0) then
l = l .or. f .ne. 'ffffffff0' .or. p .ne. '_abc' .or. r .ne. '1_23'
else if (m .eq. 1) then
l = l .or. f .ne. '__' .or. p .ne. 'xxx' .or. r .ne. '7575'
else if (m .eq. 2) then
l = l .or. f .ne. 'ZZ' .or. p .ne. 'm2' .or. r .ne. 'M2'
else if (m .eq. 3) then
l = l .or. f .ne. 'YY' .or. p .ne. 'm3' .or. r .ne. 'M3'
end if
!$omp end parallel
if (l) call abort
end subroutine test
end
/character2.f90
0,0 → 1,61
! { dg-do run }
!$ use omp_lib
 
character (len = 8) :: h
character (len = 9) :: i
h = '01234567'
i = 'ABCDEFGHI'
call test (h, i, 9)
contains
subroutine test (p, q, n)
character (len = *) :: p
character (len = n) :: q
character (len = n) :: r
character (len = n) :: t
character (len = n) :: u
integer, dimension (n + 4) :: s
logical :: l
integer :: m
r = ''
if (n .gt. 8) r = 'jklmnopqr'
do m = 1, n + 4
s(m) = m
end do
u = 'abc'
l = .false.
!$omp parallel firstprivate (p, q, r) private (t, m) reduction (.or.:l) &
!$omp & num_threads (2)
do m = 1, 13
if (s(m) .ne. m) l = .true.
end do
m = omp_get_thread_num ()
l = l .or. p .ne. '01234567' .or. q .ne. 'ABCDEFGHI'
l = l .or. r .ne. 'jklmnopqr' .or. u .ne. 'abc'
!$omp barrier
if (m .eq. 0) then
p = 'A'
q = 'B'
r = 'C'
t = '123'
u = '987654321'
else if (m .eq. 1) then
p = 'D'
q = 'E'
r = 'F'
t = '456'
s = m
end if
!$omp barrier
l = l .or. u .ne. '987654321'
if (any (s .ne. 1)) l = .true.
if (m .eq. 0) then
l = l .or. p .ne. 'A' .or. q .ne. 'B' .or. r .ne. 'C'
l = l .or. t .ne. '123'
else
l = l .or. p .ne. 'D' .or. q .ne. 'E' .or. r .ne. 'F'
l = l .or. t .ne. '456'
end if
!$omp end parallel
if (l) call abort
end subroutine test
end
/jacobi.f
0,0 → 1,261
* { dg-do run }
 
program main
************************************************************
* program to solve a finite difference
* discretization of Helmholtz equation :
* (d2/dx2)u + (d2/dy2)u - alpha u = f
* using Jacobi iterative method.
*
* Modified: Sanjiv Shah, Kuck and Associates, Inc. (KAI), 1998
* Author: Joseph Robicheaux, Kuck and Associates, Inc. (KAI), 1998
*
* Directives are used in this code to achieve paralleism.
* All do loops are parallized with default 'static' scheduling.
*
* Input : n - grid dimension in x direction
* m - grid dimension in y direction
* alpha - Helmholtz constant (always greater than 0.0)
* tol - error tolerance for iterative solver
* relax - Successice over relaxation parameter
* mits - Maximum iterations for iterative solver
*
* On output
* : u(n,m) - Dependent variable (solutions)
* : f(n,m) - Right hand side function
*************************************************************
implicit none
 
integer n,m,mits,mtemp
include "omp_lib.h"
double precision tol,relax,alpha
 
common /idat/ n,m,mits,mtemp
common /fdat/tol,alpha,relax
*
* Read info
*
write(*,*) "Input n,m - grid dimension in x,y direction "
n = 64
m = 64
* read(5,*) n,m
write(*,*) n, m
write(*,*) "Input alpha - Helmholts constant "
alpha = 0.5
* read(5,*) alpha
write(*,*) alpha
write(*,*) "Input relax - Successive over-relaxation parameter"
relax = 0.9
* read(5,*) relax
write(*,*) relax
write(*,*) "Input tol - error tolerance for iterative solver"
tol = 1.0E-12
* read(5,*) tol
write(*,*) tol
write(*,*) "Input mits - Maximum iterations for solver"
mits = 100
* read(5,*) mits
write(*,*) mits
 
call omp_set_num_threads (2)
 
*
* Calls a driver routine
*
call driver ()
 
stop
end
 
subroutine driver ( )
*************************************************************
* Subroutine driver ()
* This is where the arrays are allocated and initialzed.
*
* Working varaibles/arrays
* dx - grid spacing in x direction
* dy - grid spacing in y direction
*************************************************************
implicit none
 
integer n,m,mits,mtemp
double precision tol,relax,alpha
 
common /idat/ n,m,mits,mtemp
common /fdat/tol,alpha,relax
 
double precision u(n,m),f(n,m),dx,dy
 
* Initialize data
 
call initialize (n,m,alpha,dx,dy,u,f)
 
* Solve Helmholtz equation
 
call jacobi (n,m,dx,dy,alpha,relax,u,f,tol,mits)
 
* Check error between exact solution
 
call error_check (n,m,alpha,dx,dy,u,f)
 
return
end
 
subroutine initialize (n,m,alpha,dx,dy,u,f)
******************************************************
* Initializes data
* Assumes exact solution is u(x,y) = (1-x^2)*(1-y^2)
*
******************************************************
implicit none
integer n,m
double precision u(n,m),f(n,m),dx,dy,alpha
integer i,j, xx,yy
double precision PI
parameter (PI=3.1415926)
 
dx = 2.0 / (n-1)
dy = 2.0 / (m-1)
 
* Initilize initial condition and RHS
 
!$omp parallel do private(xx,yy)
do j = 1,m
do i = 1,n
xx = -1.0 + dx * dble(i-1) ! -1 < x < 1
yy = -1.0 + dy * dble(j-1) ! -1 < y < 1
u(i,j) = 0.0
f(i,j) = -alpha *(1.0-xx*xx)*(1.0-yy*yy)
& - 2.0*(1.0-xx*xx)-2.0*(1.0-yy*yy)
enddo
enddo
!$omp end parallel do
 
return
end
 
subroutine jacobi (n,m,dx,dy,alpha,omega,u,f,tol,maxit)
******************************************************************
* Subroutine HelmholtzJ
* Solves poisson equation on rectangular grid assuming :
* (1) Uniform discretization in each direction, and
* (2) Dirichlect boundary conditions
*
* Jacobi method is used in this routine
*
* Input : n,m Number of grid points in the X/Y directions
* dx,dy Grid spacing in the X/Y directions
* alpha Helmholtz eqn. coefficient
* omega Relaxation factor
* f(n,m) Right hand side function
* u(n,m) Dependent variable/Solution
* tol Tolerance for iterative solver
* maxit Maximum number of iterations
*
* Output : u(n,m) - Solution
*****************************************************************
implicit none
integer n,m,maxit
double precision dx,dy,f(n,m),u(n,m),alpha, tol,omega
*
* Local variables
*
integer i,j,k,k_local
double precision error,resid,rsum,ax,ay,b
double precision error_local, uold(n,m)
 
real ta,tb,tc,td,te,ta1,ta2,tb1,tb2,tc1,tc2,td1,td2
real te1,te2
real second
external second
*
* Initialize coefficients
ax = 1.0/(dx*dx) ! X-direction coef
ay = 1.0/(dy*dy) ! Y-direction coef
b = -2.0/(dx*dx)-2.0/(dy*dy) - alpha ! Central coeff
 
error = 10.0 * tol
k = 1
 
do while (k.le.maxit .and. error.gt. tol)
 
error = 0.0
 
* Copy new solution into old
!$omp parallel
 
!$omp do
do j=1,m
do i=1,n
uold(i,j) = u(i,j)
enddo
enddo
 
* Compute stencil, residual, & update
 
!$omp do private(resid) reduction(+:error)
do j = 2,m-1
do i = 2,n-1
* Evaluate residual
resid = (ax*(uold(i-1,j) + uold(i+1,j))
& + ay*(uold(i,j-1) + uold(i,j+1))
& + b * uold(i,j) - f(i,j))/b
* Update solution
u(i,j) = uold(i,j) - omega * resid
* Accumulate residual error
error = error + resid*resid
end do
enddo
!$omp enddo nowait
 
!$omp end parallel
 
* Error check
 
k = k + 1
 
error = sqrt(error)/dble(n*m)
*
enddo ! End iteration loop
*
print *, 'Total Number of Iterations ', k
print *, 'Residual ', error
 
return
end
 
subroutine error_check (n,m,alpha,dx,dy,u,f)
implicit none
************************************************************
* Checks error between numerical and exact solution
*
************************************************************
integer n,m
double precision u(n,m),f(n,m),dx,dy,alpha
integer i,j
double precision xx,yy,temp,error
 
dx = 2.0 / (n-1)
dy = 2.0 / (m-1)
error = 0.0
 
!$omp parallel do private(xx,yy,temp) reduction(+:error)
do j = 1,m
do i = 1,n
xx = -1.0d0 + dx * dble(i-1)
yy = -1.0d0 + dy * dble(j-1)
temp = u(i,j) - (1.0-xx*xx)*(1.0-yy*yy)
error = error + temp*temp
enddo
enddo
error = sqrt(error)/dble(n*m)
 
print *, 'Solution Error : ',error
 
return
end
/reduction2.f90
0,0 → 1,73
! { dg-do run }
!$ use omp_lib
 
logical :: l, la (4), m, ma (4), v
integer :: n, cnt
 
l = .true.
la = (/.true., .false., .true., .true./)
m = .false.
ma = (/.false., .false., .false., .true./)
v = .false.
cnt = -1
 
!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
!$omp & reduction (.and.:l, la) reduction (.or.:m, ma)
!$ if (.not. l .or. any (.not. la)) v = .true.
!$ if (m .or. any (ma)) v = .true.
n = omp_get_thread_num ()
if (n .eq. 0) then
cnt = omp_get_num_threads ()
l = .false.
la(3) = .false.
ma(2) = .true.
else if (n .eq. 1) then
l = .false.
la(4) = .false.
ma(1) = .true.
else
la(3) = .false.
m = .true.
ma(1) = .true.
end if
!$omp end parallel
if (v) call abort
if (cnt .eq. 3) then
if (l .or. any (la .neqv. (/.true., .false., .false., .false./))) call abort
if (.not. m .or. any (ma .neqv. (/.true., .true., .false., .true./))) call abort
end if
 
l = .true.
la = (/.true., .false., .true., .true./)
m = .false.
ma = (/.false., .false., .false., .true./)
v = .false.
cnt = -1
 
!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
!$omp & reduction (.eqv.:l, la) reduction (.neqv.:m, ma)
!$ if (.not. l .or. any (.not. la)) v = .true.
!$ if (m .or. any (ma)) v = .true.
n = omp_get_thread_num ()
if (n .eq. 0) then
cnt = omp_get_num_threads ()
l = .false.
la(3) = .false.
ma(2) = .true.
else if (n .eq. 1) then
l = .false.
la(4) = .false.
ma(1) = .true.
else
la(3) = .false.
m = .true.
ma(1) = .true.
end if
!$omp end parallel
if (v) call abort
if (cnt .eq. 3) then
if (.not. l .or. any (la .neqv. (/.true., .false., .true., .false./))) call abort
if (.not. m .or. any (ma .neqv. (/.false., .true., .false., .true./))) call abort
end if
 
end
/reduction3.f90
0,0 → 1,103
! { dg-do run }
!$ use omp_lib
 
integer (kind = 4) :: i, ia (6), n, cnt
real :: r, ra (4)
double precision :: d, da (5)
logical :: v
 
i = 1
ia = 2
r = 3
ra = 4
d = 5.5
da = 6.5
v = .false.
cnt = -1
 
!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
!$omp & reduction (max:i, ia, r, ra, d, da)
!$ if (i .ne. -huge(i)-1 .or. any (ia .ne. -huge(ia)-1)) v = .true.
!$ if (r .ge. -1.0d38 .or. any (ra .ge. -1.0d38)) v = .true.
!$ if (d .ge. -1.0d300 .or. any (da .ge. -1.0d300)) v = .true.
n = omp_get_thread_num ()
if (n .eq. 0) then
cnt = omp_get_num_threads ()
i = 4
ia(3:5) = -2
ia(1) = 7
r = 5
ra(1:2) = 6.5
d = -2.5
da(2:4) = 8.5
else if (n .eq. 1) then
i = 2
ia(4:6) = 5
r = 1
ra(2:4) = -1.5
d = 8.5
da(1:3) = 2.5
else
i = 1
ia = 1
r = -1
ra = -1
d = 1
da = -1
end if
!$omp end parallel
if (v) call abort
if (cnt .eq. 3) then
if (i .ne. 4 .or. any (ia .ne. (/7, 2, 2, 5, 5, 5/))) call abort
if (r .ne. 5 .or. any (ra .ne. (/6.5, 6.5, 4., 4./))) call abort
if (d .ne. 8.5 .or. any (da .ne. (/6.5, 8.5, 8.5, 8.5, 6.5/))) call abort
end if
 
i = 1
ia = 2
r = 3
ra = 4
d = 5.5
da = 6.5
v = .false.
cnt = -1
 
!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
!$omp & reduction (min:i, ia, r, ra, d, da)
!$ if (i .ne. 2147483647 .or. any (ia .ne. 2147483647)) v = .true.
!$ if (r .le. 1.0d38 .or. any (ra .le. 1.0d38)) v = .true.
!$ if (d .le. 1.0d300 .or. any (da .le. 1.0d300)) v = .true.
n = omp_get_thread_num ()
if (n .eq. 0) then
cnt = omp_get_num_threads ()
i = 4
ia(3:5) = -2
ia(1) = 7
r = 5
ra(1:2) = 6.5
d = -2.5
da(2:4) = 8.5
else if (n .eq. 1) then
i = 2
ia(4:6) = 5
r = 1
ra(2:4) = -1.5
d = 8.5
da(1:3) = 2.5
else
i = 1
ia = 1
r = -1
ra = 7
ra(3) = -8.5
d = 1
da(1:4) = 6
end if
!$omp end parallel
if (v) call abort
if (cnt .eq. 3) then
if (i .ne. 1 .or. any (ia .ne. (/1, 1, -2, -2, -2, 1/))) call abort
if (r .ne. -1 .or. any (ra .ne. (/4., -1.5, -8.5, -1.5/))) call abort
if (d .ne. -2.5 .or. any (da .ne. (/2.5, 2.5, 2.5, 6., 6.5/))) call abort
end if
end
/pr32550.f90
0,0 → 1,21
! PR fortran/32550
! { dg-do run }
! { dg-require-effective-target tls_runtime }
 
integer, pointer, save :: ptr
integer, target :: targ
integer :: e
!$omp threadprivate(ptr)
e = 0
targ = 42
!$omp parallel shared(targ)
!$omp single
ptr => targ
!$omp end single copyprivate(ptr)
if (ptr.ne.42) then
!$omp atomic
e = e + 1
end if
!$omp end parallel
if (e.ne.0) call abort
end
/reduction4.f90
0,0 → 1,56
! { dg-do run }
!$ use omp_lib
 
integer (kind = 4) :: i, ia (6), j, ja (6), k, ka (6), ta (6), n, cnt, x
logical :: v
 
i = Z'ffff0f'
ia = Z'f0ff0f'
j = Z'0f0000'
ja = Z'0f5a00'
k = Z'055aa0'
ka = Z'05a5a5'
v = .false.
cnt = -1
x = not(0)
 
!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
!$omp & reduction (iand:i, ia) reduction (ior:j, ja) reduction (ieor:k, ka)
!$ if (i .ne. x .or. any (ia .ne. x)) v = .true.
!$ if (j .ne. 0 .or. any (ja .ne. 0)) v = .true.
!$ if (k .ne. 0 .or. any (ka .ne. 0)) v = .true.
n = omp_get_thread_num ()
if (n .eq. 0) then
cnt = omp_get_num_threads ()
i = Z'ff7fff'
ia(3:5) = Z'fffff1'
j = Z'078000'
ja(1:3) = 1
k = Z'78'
ka(3:6) = Z'f0f'
else if (n .eq. 1) then
i = Z'ffff77'
ia(2:5) = Z'ffafff'
j = Z'007800'
ja(2:5) = 8
k = Z'57'
ka(3:4) = Z'f0108'
else
i = Z'777fff'
ia(1:2) = Z'fffff3'
j = Z'000780'
ja(5:6) = Z'f00'
k = Z'1000'
ka(6:6) = Z'777'
end if
!$omp end parallel
if (v) call abort
if (cnt .eq. 3) then
ta = (/Z'f0ff03', Z'f0af03', Z'f0af01', Z'f0af01', Z'f0af01', Z'f0ff0f'/)
if (i .ne. Z'777f07' .or. any (ia .ne. ta)) call abort
ta = (/Z'f5a01', Z'f5a09', Z'f5a09', Z'f5a08', Z'f5f08', Z'f5f00'/)
if (j .ne. Z'fff80' .or. any (ja .ne. ta)) call abort
ta = (/Z'5a5a5', Z'5a5a5', Z'aaba2', Z'aaba2', Z'5aaaa', Z'5addd'/)
if (k .ne. Z'54a8f' .or. any (ka .ne. ta)) call abort
end if
end
/omp_cond3.F90
0,0 → 1,24
! Test conditional compilation in free form if -fopenmp
! { dg-options "-fopenmp" }
10 foo = 2&
&56
if (foo.ne.256) call abort
bar = 26
!$ 20 ba&
!$ &r = 4&
!$2
!$bar = 62
!$ bar = bar + 2
#ifdef _OPENMP
bar = bar - 1
#endif
if (bar.ne.43) call abort
baz = bar
!$ 30 baz = 5& ! Comment
!$12 &
!$ + 2
!$X baz = 0 ! Not valid OpenMP conditional compilation lines
! $ baz = 1
baz = baz + 1 !$ baz = 2
if (baz.ne.515) call abort
end
/reduction5.f90
0,0 → 1,43
! { dg-do run }
 
module reduction5
intrinsic ior, min, max
end module reduction5
 
call test1
call test2
contains
subroutine test1
use reduction5, bitwise_or => ior
integer :: n
n = Z'f'
!$omp parallel sections num_threads (3) reduction (bitwise_or: n)
n = ior (n, Z'20')
!$omp section
n = bitwise_or (Z'410', n)
!$omp section
n = bitwise_or (n, Z'2000')
!$omp end parallel sections
if (n .ne. Z'243f') call abort
end subroutine
subroutine test2
use reduction5, min => max, max => min
integer :: m, n
m = 8
n = 4
!$omp parallel sections num_threads (3) reduction (min: n) &
!$omp & reduction (max: m)
if (m .gt. 13) m = 13
if (n .lt. 11) n = 11
!$omp section
if (m .gt. 5) m = 5
if (n .lt. 15) n = 15
!$omp section
if (m .gt. 3) m = 3
if (n .lt. -1) n = -1
!$omp end parallel sections
if (m .ne. 3 .or. n .ne. 15) call abort
end subroutine test2
end
 
! { dg-final { cleanup-modules "reduction5" } }
/omp_cond4.F90
0,0 → 1,24
! Test conditional compilation in free form if -fno-openmp
! { dg-options "-fno-openmp" }
10 foo = 2&
&56
if (foo.ne.256) call abort
bar = 26
!$ 20 ba&
!$ &r = 4&
!$2
!$bar = 62
!$ bar = bar + 2
#ifdef _OPENMP
bar = bar - 1
#endif
if (bar.ne.26) call abort
baz = bar
!$ 30 baz = 5& ! Comment
!$12 &
!$ + 2
!$X baz = 0 ! Not valid OpenMP conditional compilation lines
! $ baz = 1
baz = baz + 1 !$ baz = 2
if (baz.ne.27) call abort
end
/reduction6.f90
0,0 → 1,32
! { dg-do run }
 
integer, dimension (6, 6) :: a
character (36) :: c
integer nthreads
a = 9
nthreads = -1
call foo (a (2:4, 3:5), nthreads)
if (nthreads .eq. 3) then
write (c, '(36i1)') a
if (c .ne. '999999999999966699966699966699999999') call abort
end if
contains
subroutine foo (b, nthreads)
use omp_lib
integer, dimension (3:, 5:) :: b
integer :: err, nthreads
b = 0
err = 0
!$omp parallel num_threads (3) reduction (+:b)
if (any (b .ne. 0)) then
!$omp atomic
err = err + 1
end if
!$omp master
nthreads = omp_get_num_threads ()
!$omp end master
b = 2
!$omp end parallel
if (err .gt. 0) call abort
end subroutine foo
end
/allocatable1.f90
0,0 → 1,81
! { dg-do run }
!$ use omp_lib
 
integer, allocatable :: a(:, :)
integer :: b(6, 3)
integer :: i, j
logical :: k, l
b(:, :) = 16
l = .false.
if (allocated (a)) call abort
!$omp parallel private (a, b) reduction (.or.:l)
l = l.or.allocated (a)
allocate (a(3, 6))
l = l.or..not.allocated (a)
l = l.or.size(a).ne.18.or.size(a,1).ne.3.or.size(a,2).ne.6
a(3, 2) = 1
b(3, 2) = 1
deallocate (a)
l = l.or.allocated (a)
!$omp end parallel
if (allocated (a).or.l) call abort
allocate (a(6, 3))
a(:, :) = 3
if (.not.allocated (a)) call abort
l = l.or.size(a).ne.18.or.size(a,1).ne.6.or.size(a,2).ne.3
if (l) call abort
!$omp parallel private (a, b) reduction (.or.:l)
l = l.or..not.allocated (a)
a(3, 2) = 1
b(3, 2) = 1
!$omp end parallel
if (l.or..not.allocated (a)) call abort
!$omp parallel firstprivate (a, b) reduction (.or.:l)
l = l.or..not.allocated (a)
l = l.or.size(a).ne.18.or.size(a,1).ne.6.or.size(a,2).ne.3
do i = 1, 6
l = l.or.(a(i, 1).ne.3).or.(a(i, 2).ne.3)
l = l.or.(a(i, 3).ne.3).or.(b(i, 1).ne.16)
l = l.or.(b(i, 2).ne.16).or.(b(i, 3).ne.16)
end do
a(:, :) = omp_get_thread_num ()
b(:, :) = omp_get_thread_num ()
!$omp end parallel
if (any (a.ne.3).or.any (b.ne.16).or.l) call abort
k = .true.
!$omp parallel do firstprivate (a, b, k) lastprivate (a, b) &
!$omp & reduction (.or.:l)
do i = 1, 36
l = l.or..not.allocated (a)
l = l.or.size(a).ne.18.or.size(a,1).ne.6.or.size(a,2).ne.3
if (k) then
do j = 1, 6
l = l.or.(a(j, 1).ne.3).or.(a(j, 2).ne.3)
l = l.or.(a(j, 3).ne.3).or.(b(j, 1).ne.16)
l = l.or.(b(j, 2).ne.16).or.(b(j, 3).ne.16)
end do
k = .false.
end if
a(:, :) = i + 2
b(:, :) = i
end do
if (any (a.ne.38).or.any (b.ne.36).or.l) call abort
deallocate (a)
if (allocated (a)) call abort
allocate (a (0:1, 0:3))
a(:, :) = 0
!$omp parallel do reduction (+:a) reduction (.or.:l) &
!$omp & num_threads(3) schedule(static)
do i = 0, 7
l = l.or..not.allocated (a)
l = l.or.size(a).ne.8.or.size(a,1).ne.2.or.size(a,2).ne.4
a(modulo (i, 2), i / 2) = a(modulo (i, 2), i / 2) + i
a(i / 4, modulo (i, 4)) = a(i / 4, modulo (i, 4)) + i
end do
if (l) call abort
do i = 0, 1
do j = 0, 3
if (a(i, j) .ne. (5*i + 3*j)) call abort
end do
end do
end
/allocatable2.f90
0,0 → 1,47
! { dg-do run }
! { dg-require-effective-target tls_runtime }
!$ use omp_lib
 
integer, save, allocatable :: a(:, :)
integer, allocatable :: b(:, :)
integer :: n
logical :: l
!$omp threadprivate (a)
if (allocated (a)) call abort
call omp_set_dynamic (.false.)
l = .false.
!$omp parallel num_threads (4) reduction(.or.:l)
allocate (a(-1:1, 7:10))
a(:, :) = omp_get_thread_num () + 6
l = l.or..not.allocated (a)
l = l.or.size(a).ne.12.or.size(a,1).ne.3.or.size(a,2).ne.4
!$omp end parallel
if (l.or.any(a.ne.6)) call abort ()
!$omp parallel num_threads (4) copyin (a) reduction(.or.:l) private (b)
l = l.or.allocated (b)
l = l.or..not.allocated (a)
l = l.or.size(a).ne.12.or.size(a,1).ne.3.or.size(a,2).ne.4
l = l.or.any(a.ne.6)
allocate (b(1, 3))
a(:, :) = omp_get_thread_num () + 36
b(:, :) = omp_get_thread_num () + 66
!$omp single
n = omp_get_thread_num ()
!$omp end single copyprivate (a, b)
l = l.or..not.allocated (a)
l = l.or.size(a).ne.12.or.size(a,1).ne.3.or.size(a,2).ne.4
l = l.or.any(a.ne.(n + 36))
l = l.or..not.allocated (b)
l = l.or.size(b).ne.3.or.size(b,1).ne.1.or.size(b,2).ne.3
l = l.or.any(b.ne.(n + 66))
deallocate (b)
l = l.or.allocated (b)
!$omp end parallel
if (n.lt.0 .or. n.ge.4) call abort
if (l.or.any(a.ne.(n + 36))) call abort
!$omp parallel num_threads (4) reduction(.or.:l)
deallocate (a)
l = l.or.allocated (a)
!$omp end parallel
if (l.or.allocated (a)) call abort
end
/allocatable3.f90
0,0 → 1,21
! { dg-do run }
 
integer, allocatable :: a(:)
integer :: i
logical :: l
l = .false.
if (allocated (a)) call abort
!$omp parallel private (a) reduction (.or.:l)
allocate (a (-7:-5))
l = l.or..not.allocated (a)
l = l.or.size(a).ne.3.or.size(a,1).ne.3
a(:) = 0
!$omp do private (a)
do i = 1, 7
a(:) = i
l = l.or.any (a.ne.i)
end do
l = l.or.any (a.ne.0)
deallocate (a)
!$omp end parallel
end
/workshare1.f90
0,0 → 1,30
function foo ()
integer :: foo
logical :: foo_seen
common /foo_seen/ foo_seen
foo_seen = .true.
foo = 3
end
function bar ()
integer :: bar
logical :: bar_seen
common /bar_seen/ bar_seen
bar_seen = .true.
bar = 3
end
integer :: a (10), b (10), foo, bar
logical :: foo_seen, bar_seen
common /foo_seen/ foo_seen
common /bar_seen/ bar_seen
 
foo_seen = .false.
bar_seen = .false.
!$omp parallel workshare if (foo () .gt. 2) num_threads (bar () + 1)
a = 10
b = 20
a(1:5) = max (a(1:5), b(1:5))
!$omp end parallel workshare
if (any (a(1:5) .ne. 20)) call abort
if (any (a(6:10) .ne. 10)) call abort
if (.not. foo_seen .or. .not. bar_seen) call abort
end
/workshare2.f90
0,0 → 1,37
subroutine f1
integer a(20:50,70:90)
!$omp parallel workshare
a(:,:) = 17
!$omp end parallel workshare
if (any (a.ne.17)) call abort
end subroutine f1
subroutine f2
integer a(20:50,70:90),d(15),e(15),f(15)
integer b, c, i
!$omp parallel workshare
c = 5
a(:,:) = 17
b = 4
d = (/ 0, 1, 2, 3, 4, 0, 6, 7, 8, 9, 10, 0, 0, 13, 14 /)
forall (i=1:15, d(i) /= 0)
d(i) = 0
end forall
e = (/ 4, 5, 2, 6, 4, 5, 2, 6, 4, 5, 2, 6, 4, 5, 2 /)
f = 7
where (e.ge.5) f = f + 1
!$omp end parallel workshare
if (any (a.ne.17)) call abort
if (c.ne.5.or.b.ne.4) call abort
if (any(d.ne.0)) call abort
do i = 1, 15
if (e(i).ge.5) then
if (f(i).ne.8) call abort
else
if (f(i).ne.7) call abort
end if
end do
end subroutine f2
 
call f1
call f2
end
/pr33880.f90
0,0 → 1,18
! PR middle-end/33880
! { dg-do run }
 
program pr33880
integer :: i, j
call something ()
!$omp parallel do
do i = 1, 1000
!$omp atomic
j = j + 1
end do
if (j .ne. 1000) call abort
contains
subroutine something()
i = 0
j = 0
end subroutine something
end program pr33880
/pr32359.f90
0,0 → 1,34
! { dg-do compile }
!
! PR fortran/32359
! Contributed by Bill Long <longb@cray.com>
 
subroutine test
use omp_lib
implicit none
integer, parameter :: NT = 4
integer :: a
save
!$omp threadprivate(a)
a = 1
 
!$ call omp_set_num_threads(NT)
!$omp parallel
print *, omp_get_thread_num(), a
!$omp end parallel
 
end subroutine test
 
! Derived from OpenMP test omp1/F2_6_2_8_5i.f90
use omp_lib
implicit none
integer, parameter :: NT = 4
integer :: a = 1
!$omp threadprivate(a)
 
!$ call omp_set_num_threads(NT)
!$omp parallel
print *, omp_get_thread_num(), a
!$omp end parallel
 
END
/allocatable4.f90
0,0 → 1,47
! { dg-do run }
 
integer, allocatable :: a(:, :)
integer :: b(6, 3)
integer :: i, j
logical :: k, l
b(:, :) = 16
l = .false.
if (allocated (a)) call abort
!$omp task private (a, b) shared (l)
l = l.or.allocated (a)
allocate (a(3, 6))
l = l.or..not.allocated (a)
l = l.or.size(a).ne.18.or.size(a,1).ne.3.or.size(a,2).ne.6
a(3, 2) = 1
b(3, 2) = 1
deallocate (a)
l = l.or.allocated (a)
!$omp end task
!$omp taskwait
if (allocated (a).or.l) call abort
allocate (a(6, 3))
a(:, :) = 3
if (.not.allocated (a)) call abort
l = l.or.size(a).ne.18.or.size(a,1).ne.6.or.size(a,2).ne.3
if (l) call abort
!$omp task private (a, b) shared (l)
l = l.or..not.allocated (a)
a(3, 2) = 1
b(3, 2) = 1
!$omp end task
!$omp taskwait
if (l.or..not.allocated (a)) call abort
!$omp task firstprivate (a, b) shared (l)
l = l.or..not.allocated (a)
l = l.or.size(a).ne.18.or.size(a,1).ne.6.or.size(a,2).ne.3
do i = 1, 6
l = l.or.(a(i, 1).ne.3).or.(a(i, 2).ne.3)
l = l.or.(a(i, 3).ne.3).or.(b(i, 1).ne.16)
l = l.or.(b(i, 2).ne.16).or.(b(i, 3).ne.16)
end do
a(:, :) = 7
b(:, :) = 8
!$omp end task
!$omp taskwait
if (any (a.ne.3).or.any (b.ne.16).or.l) call abort
end
/allocatable5.f90
0,0 → 1,17
! PR fortran/42866
! { dg-do run }
 
program pr42866
integer, allocatable :: a(:)
allocate (a(16))
a = 0
!$omp parallel
!$omp sections reduction(+:a)
a = a + 1
!$omp section
a = a + 2
!$omp end sections
!$omp end parallel
if (any (a.ne.3)) call abort
deallocate (a)
end
/omp_workshare2.f
0,0 → 1,56
C******************************************************************************
C FILE: omp_workshare2.f
C DESCRIPTION:
C OpenMP Example - Sections Work-sharing - Fortran Version
C In this example, the OpenMP SECTION directive is used to assign
C different array operations to threads that execute a SECTION. Each
C thread receives its own copy of the result array to work with.
C AUTHOR: Blaise Barney 5/99
C LAST REVISED: 01/09/04
C******************************************************************************
 
PROGRAM WORKSHARE2
 
INTEGER N, I, NTHREADS, TID, OMP_GET_NUM_THREADS,
+ OMP_GET_THREAD_NUM
PARAMETER (N=50)
REAL A(N), B(N), C(N)
 
! Some initializations
DO I = 1, N
A(I) = I * 1.0
B(I) = A(I)
ENDDO
 
!$OMP PARALLEL SHARED(A,B,NTHREADS), PRIVATE(C,I,TID)
TID = OMP_GET_THREAD_NUM()
IF (TID .EQ. 0) THEN
NTHREADS = OMP_GET_NUM_THREADS()
PRINT *, 'Number of threads =', NTHREADS
END IF
PRINT *, 'Thread',TID,' starting...'
 
!$OMP SECTIONS
 
!$OMP SECTION
PRINT *, 'Thread',TID,' doing section 1'
DO I = 1, N
C(I) = A(I) + B(I)
WRITE(*,100) TID,I,C(I)
100 FORMAT(' Thread',I2,': C(',I2,')=',F8.2)
ENDDO
 
!$OMP SECTION
PRINT *, 'Thread',TID,' doing section 2'
DO I = 1+N/2, N
C(I) = A(I) * B(I)
WRITE(*,100) TID,I,C(I)
ENDDO
 
!$OMP END SECTIONS NOWAIT
 
PRINT *, 'Thread',TID,' done.'
 
!$OMP END PARALLEL
 
END
/recursion1.f90
0,0 → 1,28
! { dg-do run }
! { dg-options "-fopenmp -fcheck=recursion" }
!
! PR 42517: Bogus runtime error with -fopenmp -fcheck=recursion
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
 
implicit none
integer :: i,s
 
s=0
!$omp parallel do private(i) shared(s)
do i=1,10
call sub(i)
end do
!$omp end parallel do
if (s/=55) call abort()
 
contains
 
subroutine sub (n)
integer :: n
!$omp atomic
s = s + n
print '(A,i3)',"loop =",n
end subroutine
 
end
/pr29629.f90
0,0 → 1,20
! PR fortran/29629
! { dg-do run }
 
program pr29629
integer :: n
n = 10000
if (any (func(n).ne.10000)) call abort
contains
function func(n)
integer, intent(in) :: n
integer, dimension(n) :: func
integer :: k
func = 0
!$omp parallel do private(k), reduction(+:func), num_threads(4)
do k = 1, n
func = func + 1
end do
!$omp end parallel do
end function
end program
/omp_reduction.f
0,0 → 1,33
C******************************************************************************
C FILE: omp_reduction.f
C DESCRIPTION:
C OpenMP Example - Combined Parallel Loop Reduction - Fortran Version
C This example demonstrates a sum reduction within a combined parallel loop
C construct. Notice that default data element scoping is assumed - there
C are no clauses specifying shared or private variables. OpenMP will
C automatically make loop index variables private within team threads, and
C global variables shared.
C AUTHOR: Blaise Barney 5/99
C LAST REVISED:
C******************************************************************************
 
PROGRAM REDUCTION
 
INTEGER I, N
REAL A(100), B(100), SUM
 
! Some initializations
N = 100
DO I = 1, N
A(I) = I *1.0
B(I) = A(I)
ENDDO
SUM = 0.0
 
!$OMP PARALLEL DO REDUCTION(+:SUM)
DO I = 1, N
SUM = SUM + (A(I) * B(I))
ENDDO
 
PRINT *, ' Sum = ', SUM
END
/strassen.f90
0,0 → 1,75
! { dg-options "-O2" }
 
program strassen_matmul
use omp_lib
integer, parameter :: N = 1024
double precision, save :: A(N,N), B(N,N), C(N,N), D(N,N)
double precision :: start, end
 
call random_seed
call random_number (A)
call random_number (B)
start = omp_get_wtime ()
C = matmul (A, B)
end = omp_get_wtime ()
write(*,'(a, f10.6)') ' Time for matmul = ', end - start
D = 0
start = omp_get_wtime ()
call strassen (A, B, D, N)
end = omp_get_wtime ()
write(*,'(a, f10.6)') ' Time for Strassen = ', end - start
if (sqrt (sum ((C - D) ** 2)) / N .gt. 0.1) call abort
D = 0
start = omp_get_wtime ()
!$omp parallel
!$omp single
call strassen (A, B, D, N)
!$omp end single nowait
!$omp end parallel
end = omp_get_wtime ()
write(*,'(a, f10.6)') ' Time for Strassen MP = ', end - start
if (sqrt (sum ((C - D) ** 2)) / N .gt. 0.1) call abort
 
contains
 
recursive subroutine strassen (A, B, C, N)
integer, intent(in) :: N
double precision, intent(in) :: A(N,N), B(N,N)
double precision, intent(out) :: C(N,N)
double precision :: T(N/2,N/2,7)
integer :: K, L
 
if (iand (N,1) .ne. 0 .or. N < 64) then
C = matmul (A, B)
return
end if
K = N / 2
L = N / 2 + 1
!$omp task shared (A, B, T)
call strassen (A(:K,:K) + A(L:,L:), B(:K,:K) + B(L:,L:), T(:,:,1), K)
!$omp end task
!$omp task shared (A, B, T)
call strassen (A(L:,:K) + A(L:,L:), B(:K,:K), T(:,:,2), K)
!$omp end task
!$omp task shared (A, B, T)
call strassen (A(:K,:K), B(:K,L:) - B(L:,L:), T(:,:,3), K)
!$omp end task
!$omp task shared (A, B, T)
call strassen (A(L:,L:), B(L:,:K) - B(:K,:K), T(:,:,4), K)
!$omp end task
!$omp task shared (A, B, T)
call strassen (A(:K,:K) + A(:K,L:), B(L:,L:), T(:,:,5), K)
!$omp end task
!$omp task shared (A, B, T)
call strassen (A(L:,:K) - A(:K,:K), B(:K,:K) + B(:K,L:), T(:,:,6), K)
!$omp end task
!$omp task shared (A, B, T)
call strassen (A(:K,L:) - A(L:,L:), B(L:,:K) + B(L:,L:), T(:,:,7), K)
!$omp end task
!$omp taskwait
C(:K,:K) = T(:,:,1) + T(:,:,4) - T(:,:,5) + T(:,:,7)
C(L:,:K) = T(:,:,2) + T(:,:,4)
C(:K,L:) = T(:,:,3) + T(:,:,5)
C(L:,L:) = T(:,:,1) - T(:,:,2) + T(:,:,3) + T(:,:,6)
end subroutine strassen
end
/vla1.f90
0,0 → 1,185
! { dg-do run }
 
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
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) firstprivate (c, d, e, f, g, h, i, j, k) &
!$omp & firstprivate (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
x = omp_get_thread_num ()
w = ''
if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
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)
!$omp barrier
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
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) call abort
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
/vla2.f90
0,0 → 1,142
! { dg-do run }
 
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
character (len = 1) :: y
l = .false.
!$omp parallel default (none) private (c, d, e, f, g, h, i, j, k) &
!$omp & private (s, t, u, v) reduction (.or.:l) num_threads (6) &
!$omp private (p, q, r, w, x, y)
x = omp_get_thread_num ()
w = ''
if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
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)
!$omp barrier
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
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) call abort
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
call foo (c, d, e, f, g, h, i, j, k, 7)
end subroutine test
end
/vla3.f90
0,0 → 1,191
! { dg-do run }
 
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) call abort
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
/vla4.f90
0,0 → 1,228
! { dg-do run }
 
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, z2
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.
call omp_set_dynamic (.false.)
call omp_set_num_threads (6)
!$omp parallel do default (none) firstprivate (c, d, e, f, g, h, i, j, k) &
!$omp & firstprivate (s, t, u, v) reduction (.or.:l) num_threads (6) &
!$omp private (p, q, r, w, x, y) schedule (static) shared (z2) &
!$omp lastprivate (c, d, e, f, g, h, i, j, k, s, t, u, v)
do 110 z = 0, omp_get_num_threads () - 1
if (omp_get_thread_num () .eq. 0) z2 = omp_get_num_threads ()
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
x = omp_get_thread_num ()
w = ''
if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
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)
!$omp barrier ! { dg-warning "may not be closely nested" }
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
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)
110 continue
!$omp end parallel do
if (l) call abort
if (z2 == 6) then
x = 5
w = 'thread5thr_number_5THREAD5THR_NUMBER_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 113, p = 1, 2
do 113, q = 3, 7
do 113, 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)
113 continue
do 114, p = 3, 5
do 114, q = 2, 6
do 114, 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
114 continue
do 115, p = 1, 5
do 115, q = 4, 6
l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
115 continue
if (l) call abort
end if
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
/omp_cond1.f
0,0 → 1,22
C Test conditional compilation in fixed form if -fopenmp
! { dg-options "-fopenmp" }
10 foo = 2
&56
if (foo.ne.256) call abort
bar = 26
!$2 0 ba
c$ +r = 42
!$ bar = 62
!$ bar = bar + 1
if (bar.ne.43) call abort
baz = bar
*$ 0baz = 5
C$ +12! Comment
c$ !4
!$ +!Another comment
*$ &2
!$ X baz = 0 ! Not valid OpenMP conditional compilation lines
! $ baz = 1
c$ 10&baz = 2
if (baz.ne.51242) call abort
end
/vla5.f90
0,0 → 1,200
! { dg-do run }
 
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, z2
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.
call omp_set_dynamic (.false.)
call omp_set_num_threads (6)
!$omp parallel do default (none) lastprivate (c, d, e, f, g, h, i, j, k) &
!$omp & lastprivate (s, t, u, v) reduction (.or.:l) num_threads (6) &
!$omp private (p, q, r, w, x, y) schedule (static) shared (z2)
do 110 z = 0, omp_get_num_threads () - 1
if (omp_get_thread_num () .eq. 0) z2 = omp_get_num_threads ()
x = omp_get_thread_num ()
w = ''
if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
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)
!$omp barrier ! { dg-warning "may not be closely nested" }
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
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)
110 continue
!$omp end parallel do
if (l) call abort
if (z2 == 6) then
x = 5
w = 'thread5thr_number_5THREAD5THR_NUMBER_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 113, p = 1, 2
do 113, q = 3, 7
do 113, 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)
113 continue
do 114, p = 3, 5
do 114, q = 2, 6
do 114, 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
114 continue
do 115, p = 1, 5
do 115, q = 4, 6
l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
115 continue
if (l) call abort
end if
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
/vla6.f90
0,0 → 1,191
! { dg-do run }
 
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
l = .false.
!$omp parallel default (none) private (c, d, e, f, g, h, i, j, k) &
!$omp & private (s, t, u, v) reduction (.or.:l) num_threads (6) &
!$omp private (p, q, r, w, x, y) shared (z)
x = omp_get_thread_num ()
w = ''
if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
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)
!$omp barrier
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
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 single
z = omp_get_thread_num ()
!$omp end single copyprivate (c, d, e, f, g, h, i, j, k, s, t, u, v)
w = ''
x = z
if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
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 113, p = 1, 2
do 113, q = 3, 7
do 113, 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)
113 continue
do 114, p = 3, 5
do 114, q = 2, 6
do 114, 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
114 continue
do 115, p = 1, 5
do 115, q = 4, 6
l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
115 continue
!$omp end parallel
if (l) call abort
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
call foo (c, d, e, f, g, h, i, j, k, 7)
end subroutine test
end
/vla7.f90
0,0 → 1,143
! { dg-do run }
! { dg-options "-w" }
 
character (6) :: c, f2
character (6) :: d(2)
c = f1 (6)
if (c .ne. 'opqrst') call abort
c = f2 (6)
if (c .ne. '_/!!/_') call abort
d = f3 (6)
if (d(1) .ne. 'opqrst' .or. d(2) .ne. 'a') call abort
d = f4 (6)
if (d(1) .ne. 'Opqrst' .or. d(2) .ne. 'A') call abort
contains
function f1 (n)
use omp_lib
character (n) :: f1
logical :: l
f1 = 'abcdef'
l = .false.
!$omp parallel firstprivate (f1) reduction (.or.:l) num_threads (2)
l = f1 .ne. 'abcdef'
if (omp_get_thread_num () .eq. 0) f1 = 'ijklmn'
if (omp_get_thread_num () .eq. 1) f1 = 'IJKLMN'
!$omp barrier
l = l .or. (omp_get_thread_num () .eq. 0 .and. f1 .ne. 'ijklmn')
l = l .or. (omp_get_thread_num () .eq. 1 .and. f1 .ne. 'IJKLMN')
!$omp end parallel
f1 = 'zZzz_z'
!$omp parallel shared (f1) reduction (.or.:l) num_threads (2)
l = l .or. f1 .ne. 'zZzz_z'
!$omp barrier
!$omp master
f1 = 'abc'
!$omp end master
!$omp barrier
l = l .or. f1 .ne. 'abc'
!$omp barrier
if (omp_get_thread_num () .eq. 1) f1 = 'def'
!$omp barrier
l = l .or. f1 .ne. 'def'
!$omp end parallel
if (l) call abort
f1 = 'opqrst'
end function f1
function f3 (n)
use omp_lib
character (n), dimension (2) :: f3
logical :: l
f3 = 'abcdef'
l = .false.
!$omp parallel firstprivate (f3) reduction (.or.:l) num_threads (2)
l = any (f3 .ne. 'abcdef')
if (omp_get_thread_num () .eq. 0) f3 = 'ijklmn'
if (omp_get_thread_num () .eq. 1) f3 = 'IJKLMN'
!$omp barrier
l = l .or. (omp_get_thread_num () .eq. 0 .and. any (f3 .ne. 'ijklmn'))
l = l .or. (omp_get_thread_num () .eq. 1 .and. any (f3 .ne. 'IJKLMN'))
!$omp end parallel
f3 = 'zZzz_z'
!$omp parallel shared (f3) reduction (.or.:l) num_threads (2)
l = l .or. any (f3 .ne. 'zZzz_z')
!$omp barrier
!$omp master
f3 = 'abc'
!$omp end master
!$omp barrier
l = l .or. any (f3 .ne. 'abc')
!$omp barrier
if (omp_get_thread_num () .eq. 1) f3 = 'def'
!$omp barrier
l = l .or. any (f3 .ne. 'def')
!$omp end parallel
if (l) call abort
f3(1) = 'opqrst'
f3(2) = 'a'
end function f3
function f4 (n)
use omp_lib
character (n), dimension (n - 4) :: f4
logical :: l
f4 = 'abcdef'
l = .false.
!$omp parallel firstprivate (f4) reduction (.or.:l) num_threads (2)
l = any (f4 .ne. 'abcdef')
if (omp_get_thread_num () .eq. 0) f4 = 'ijklmn'
if (omp_get_thread_num () .eq. 1) f4 = 'IJKLMN'
!$omp barrier
l = l .or. (omp_get_thread_num () .eq. 0 .and. any (f4 .ne. 'ijklmn'))
l = l .or. (omp_get_thread_num () .eq. 1 .and. any (f4 .ne. 'IJKLMN'))
l = l .or. size (f4) .ne. 2
!$omp end parallel
f4 = 'zZzz_z'
!$omp parallel shared (f4) reduction (.or.:l) num_threads (2)
l = l .or. any (f4 .ne. 'zZzz_z')
!$omp barrier
!$omp master
f4 = 'abc'
!$omp end master
!$omp barrier
l = l .or. any (f4 .ne. 'abc')
!$omp barrier
if (omp_get_thread_num () .eq. 1) f4 = 'def'
!$omp barrier
l = l .or. any (f4 .ne. 'def')
l = l .or. size (f4) .ne. 2
!$omp end parallel
if (l) call abort
f4(1) = 'Opqrst'
f4(2) = 'A'
end function f4
end
function f2 (n)
use omp_lib
character (*) :: f2
logical :: l
f2 = 'abcdef'
l = .false.
!$omp parallel firstprivate (f2) reduction (.or.:l) num_threads (2)
l = f2 .ne. 'abcdef'
if (omp_get_thread_num () .eq. 0) f2 = 'ijklmn'
if (omp_get_thread_num () .eq. 1) f2 = 'IJKLMN'
!$omp barrier
l = l .or. (omp_get_thread_num () .eq. 0 .and. f2 .ne. 'ijklmn')
l = l .or. (omp_get_thread_num () .eq. 1 .and. f2 .ne. 'IJKLMN')
!$omp end parallel
f2 = 'zZzz_z'
!$omp parallel shared (f2) reduction (.or.:l) num_threads (2)
l = l .or. f2 .ne. 'zZzz_z'
!$omp barrier
!$omp master
f2 = 'abc'
!$omp end master
!$omp barrier
l = l .or. f2 .ne. 'abc'
!$omp barrier
if (omp_get_thread_num () .eq. 1) f2 = 'def'
!$omp barrier
l = l .or. f2 .ne. 'def'
!$omp end parallel
if (l) call abort
f2 = '_/!!/_'
end function f2
/vla8.f90
0,0 → 1,254
! { dg-do run }
 
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
l = .false.
!$omp parallel default (none) private (c, d, e, f, g, h, i, j, k) &
!$omp & private (s, t, u, v) reduction (.or.:l) num_threads (6) &
!$omp private (p, q, r, w, x, y) shared (z)
x = omp_get_thread_num ()
w = ''
if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
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)
!$omp barrier
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
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 single
z = omp_get_thread_num ()
!$omp end single copyprivate (c, d, e, f, g, h, i, j, k, s, t, u, v)
w = ''
x = z
if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
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 113, p = 1, 2
do 113, q = 3, 7
do 113, 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)
113 continue
do 114, p = 3, 5
do 114, q = 2, 6
do 114, 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
114 continue
do 115, p = 1, 5
do 115, q = 4, 6
l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
115 continue
x = omp_get_thread_num ()
w = ''
if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0'
if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1'
if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2'
if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3'
if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4'
if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5'
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)
!$omp barrier
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 123, p = 1, 2
do 123, q = 3, 7
do 123, 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)
123 continue
do 124, p = 3, 5
do 124, q = 2, 6
do 124, 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
124 continue
do 125, p = 1, 5
do 125, q = 4, 6
l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q
125 continue
!$omp end parallel
if (l) call abort
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
call foo (c, d, e, f, g, h, i, j, k, 7)
end subroutine test
end
/pr34020.f90
0,0 → 1,19
! PR fortran/34020
! { dg-do run }
 
subroutine atomic_add(lhs, rhs)
real lhs, rhs
!$omp atomic
lhs = rhs + lhs
end
 
real lhs, rhs
integer i
lhs = 0
rhs = 1
!$omp parallel do num_threads(8) shared(lhs, rhs)
do i = 1, 300000
call atomic_add(lhs, rhs)
enddo
if (lhs .ne. 300000) call abort
end
/retval1.f90
0,0 → 1,120
! { dg-do run }
 
function f1 ()
use omp_lib
real :: f1
logical :: l
f1 = 6.5
l = .false.
!$omp parallel firstprivate (f1) num_threads (2) reduction (.or.:l)
l = f1 .ne. 6.5
if (omp_get_thread_num () .eq. 0) f1 = 8.5
if (omp_get_thread_num () .eq. 1) f1 = 14.5
!$omp barrier
l = l .or. (omp_get_thread_num () .eq. 0 .and. f1 .ne. 8.5)
l = l .or. (omp_get_thread_num () .eq. 1 .and. f1 .ne. 14.5)
!$omp end parallel
if (l) call abort
f1 = -2.5
end function f1
function f2 ()
use omp_lib
real :: f2, e2
logical :: l
entry e2 ()
f2 = 6.5
l = .false.
!$omp parallel firstprivate (e2) num_threads (2) reduction (.or.:l)
l = e2 .ne. 6.5
if (omp_get_thread_num () .eq. 0) e2 = 8.5
if (omp_get_thread_num () .eq. 1) e2 = 14.5
!$omp barrier
l = l .or. (omp_get_thread_num () .eq. 0 .and. e2 .ne. 8.5)
l = l .or. (omp_get_thread_num () .eq. 1 .and. e2 .ne. 14.5)
!$omp end parallel
if (l) call abort
e2 = 7.5
end function f2
function f3 ()
use omp_lib
real :: f3, e3
logical :: l
entry e3 ()
f3 = 6.5
l = .false.
!$omp parallel firstprivate (f3, e3) num_threads (2) reduction (.or.:l)
l = e3 .ne. 6.5
l = l .or. f3 .ne. 6.5
if (omp_get_thread_num () .eq. 0) e3 = 8.5
if (omp_get_thread_num () .eq. 1) e3 = 14.5
f3 = e3 - 4.5
!$omp barrier
l = l .or. (omp_get_thread_num () .eq. 0 .and. e3 .ne. 8.5)
l = l .or. (omp_get_thread_num () .eq. 1 .and. e3 .ne. 14.5)
l = l .or. f3 .ne. e3 - 4.5
!$omp end parallel
if (l) call abort
e3 = 0.5
end function f3
function f4 () result (r4)
use omp_lib
real :: r4, s4
logical :: l
entry e4 () result (s4)
r4 = 6.5
l = .false.
!$omp parallel firstprivate (r4, s4) num_threads (2) reduction (.or.:l)
l = s4 .ne. 6.5
l = l .or. r4 .ne. 6.5
if (omp_get_thread_num () .eq. 0) s4 = 8.5
if (omp_get_thread_num () .eq. 1) s4 = 14.5
r4 = s4 - 4.5
!$omp barrier
l = l .or. (omp_get_thread_num () .eq. 0 .and. s4 .ne. 8.5)
l = l .or. (omp_get_thread_num () .eq. 1 .and. s4 .ne. 14.5)
l = l .or. r4 .ne. s4 - 4.5
!$omp end parallel
if (l) call abort
s4 = -0.5
end function f4
function f5 (is_f5)
use omp_lib
real :: f5
integer :: e5
logical :: l, is_f5
entry e5 (is_f5)
if (is_f5) then
f5 = 6.5
else
e5 = 8
end if
l = .false.
!$omp parallel firstprivate (f5, e5) shared (is_f5) num_threads (2) &
!$omp reduction (.or.:l)
l = .not. is_f5 .and. e5 .ne. 8
l = l .or. (is_f5 .and. f5 .ne. 6.5)
if (omp_get_thread_num () .eq. 0) e5 = 8
if (omp_get_thread_num () .eq. 1) e5 = 14
f5 = e5 - 4.5
!$omp barrier
l = l .or. (omp_get_thread_num () .eq. 0 .and. e5 .ne. 8)
l = l .or. (omp_get_thread_num () .eq. 1 .and. e5 .ne. 14)
l = l .or. f5 .ne. e5 - 4.5
!$omp end parallel
if (l) call abort
if (is_f5) f5 = -2.5
if (.not. is_f5) e5 = 8
end function f5
 
real :: f1, f2, e2, f3, e3, f4, e4, f5
integer :: e5
if (f1 () .ne. -2.5) call abort
if (f2 () .ne. 7.5) call abort
if (e2 () .ne. 7.5) call abort
if (f3 () .ne. 0.5) call abort
if (e3 () .ne. 0.5) call abort
if (f4 () .ne. -0.5) call abort
if (e4 () .ne. -0.5) call abort
if (f5 (.true.) .ne. -2.5) call abort
if (e5 (.false.) .ne. 8) call abort
end
/retval2.f90
0,0 → 1,27
! { dg-do run }
 
function f1 ()
real :: f1
f1 = 6.5
call sub1
contains
subroutine sub1
use omp_lib
logical :: l
l = .false.
!$omp parallel firstprivate (f1) num_threads (2) reduction (.or.:l)
l = f1 .ne. 6.5
if (omp_get_thread_num () .eq. 0) f1 = 8.5
if (omp_get_thread_num () .eq. 1) f1 = 14.5
!$omp barrier
l = l .or. (omp_get_thread_num () .eq. 0 .and. f1 .ne. 8.5)
l = l .or. (omp_get_thread_num () .eq. 1 .and. f1 .ne. 14.5)
!$omp end parallel
if (l) call abort
f1 = -2.5
end subroutine sub1
end function f1
 
real :: f1
if (f1 () .ne. -2.5) call abort
end
/pr42162.f90
0,0 → 1,53
! PR fortran/42162
! { dg-do run }
 
subroutine sub1(k, a)
implicit none
integer :: k, a(3)
!$omp do
do k=1,3
a(k) = a(k) + 1
enddo
!$omp end do
end subroutine sub1
 
subroutine sub2(k, a)
implicit none
integer :: k, a(3)
!$omp do private (k)
do k=1,3
a(k) = a(k) + 1
enddo
!$omp end do
end subroutine sub2
 
subroutine sub3(k, a)
implicit none
integer :: k, a(3)
!$omp do lastprivate (k)
do k=1,3
a(k) = a(k) + 1
enddo
!$omp end do
end subroutine sub3
 
program pr42162
implicit none
integer :: k, a(3), b(3), c(3)
a = 1
b = 2
c = 3
k = 3
!$omp parallel num_threads(3)
call sub1 (k, a)
!$omp end parallel
k = 4
!$omp parallel num_threads(3)
call sub2 (k, b)
!$omp end parallel
k = 10
!$omp parallel num_threads(3)
call sub3 (k, c)
!$omp end parallel
if (k.ne.4.or.any(a.ne.2).or.any(b.ne.3).or.any(c.ne.4)) call abort
end
/lib3.f
0,0 → 1,76
C { dg-do run }
 
INCLUDE "omp_lib.h"
 
DOUBLE PRECISION :: D, E
LOGICAL :: L
INTEGER (KIND = OMP_LOCK_KIND) :: LCK
INTEGER (KIND = OMP_NEST_LOCK_KIND) :: NLCK
 
D = OMP_GET_WTIME ()
 
CALL OMP_INIT_LOCK (LCK)
CALL OMP_SET_LOCK (LCK)
IF (OMP_TEST_LOCK (LCK)) CALL ABORT
CALL OMP_UNSET_LOCK (LCK)
IF (.NOT. OMP_TEST_LOCK (LCK)) CALL ABORT
IF (OMP_TEST_LOCK (LCK)) CALL ABORT
CALL OMP_UNSET_LOCK (LCK)
CALL OMP_DESTROY_LOCK (LCK)
 
CALL OMP_INIT_NEST_LOCK (NLCK)
IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 1) CALL ABORT
CALL OMP_SET_NEST_LOCK (NLCK)
IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 3) CALL ABORT
CALL OMP_UNSET_NEST_LOCK (NLCK)
CALL OMP_UNSET_NEST_LOCK (NLCK)
IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 2) CALL ABORT
CALL OMP_UNSET_NEST_LOCK (NLCK)
CALL OMP_UNSET_NEST_LOCK (NLCK)
CALL OMP_DESTROY_NEST_LOCK (NLCK)
 
CALL OMP_SET_DYNAMIC (.TRUE.)
IF (.NOT. OMP_GET_DYNAMIC ()) CALL ABORT
CALL OMP_SET_DYNAMIC (.FALSE.)
IF (OMP_GET_DYNAMIC ()) CALL ABORT
 
CALL OMP_SET_NESTED (.TRUE.)
IF (.NOT. OMP_GET_NESTED ()) CALL ABORT
CALL OMP_SET_NESTED (.FALSE.)
IF (OMP_GET_NESTED ()) CALL ABORT
 
CALL OMP_SET_NUM_THREADS (5)
IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT
IF (OMP_GET_MAX_THREADS () .NE. 5) CALL ABORT
IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT
CALL OMP_SET_NUM_THREADS (3)
IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT
IF (OMP_GET_MAX_THREADS () .NE. 3) CALL ABORT
IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT
L = .FALSE.
C$OMP PARALLEL REDUCTION (.OR.:L)
L = OMP_GET_NUM_THREADS () .NE. 3
L = L .OR. (OMP_GET_THREAD_NUM () .LT. 0)
L = L .OR. (OMP_GET_THREAD_NUM () .GE. 3)
C$OMP MASTER
L = L .OR. (OMP_GET_THREAD_NUM () .NE. 0)
C$OMP END MASTER
C$OMP END PARALLEL
IF (L) CALL ABORT
 
IF (OMP_GET_NUM_PROCS () .LE. 0) CALL ABORT
IF (OMP_IN_PARALLEL ()) CALL ABORT
C$OMP PARALLEL REDUCTION (.OR.:L)
L = .NOT. OMP_IN_PARALLEL ()
C$OMP END PARALLEL
C$OMP PARALLEL REDUCTION (.OR.:L) IF (.TRUE.)
L = .NOT. OMP_IN_PARALLEL ()
C$OMP END PARALLEL
 
E = OMP_GET_WTIME ()
IF (D .GT. E) CALL ABORT
D = OMP_GET_WTICK ()
C Negative precision is definitely wrong,
C bigger than 1s clock resolution is also strange
IF (D .LE. 0 .OR. D .GT. 1.) CALL ABORT
END
/threadprivate1.f90
0,0 → 1,21
! { dg-do run }
! { dg-require-effective-target tls_runtime }
 
module threadprivate1
double precision :: d
!$omp threadprivate (d)
end module threadprivate1
 
!$ use omp_lib
use threadprivate1
logical :: l
l = .false.
!$omp parallel num_threads (4) reduction (.or.:l)
d = omp_get_thread_num () + 6.5
!$omp barrier
if (d .ne. omp_get_thread_num () + 6.5) l = .true.
!$omp end parallel
if (l) call abort ()
end
 
! { dg-final { cleanup-modules "threadprivate1" } }
/task1.f90
0,0 → 1,27
! { dg-do run }
 
program tasktest
use omp_lib
integer :: i, j
common /tasktest_j/ j
j = 0
!$omp parallel private (i)
i = omp_get_thread_num ()
if (i.lt.2) then
!$omp task if (.false.) default(firstprivate)
call subr (i + 1)
!$omp end task
end if
!$omp end parallel
if (j.gt.0) call abort
contains
subroutine subr (i)
use omp_lib
integer :: i, j
common /tasktest_j/ j
if (omp_get_thread_num ().ne.(i - 1)) then
!$omp atomic
j = j + 1
end if
end subroutine subr
end program tasktest
/do1.f90
0,0 → 1,179
! { dg-do run }
 
integer, dimension (128) :: a, b
integer :: i
a = -1
b = -1
do i = 1, 128
if (i .ge. 8 .and. i .le. 15) then
b(i) = 1 * 256 + i
else if (i .ge. 19 .and. i .le. 23) then
b(i) = 2 * 256 + i
else if (i .ge. 28 .and. i .le. 38) then
if (iand (i, 1) .eq. 0) b(i) = 3 * 256 + i
else if (i .ge. 59 .and. i .le. 79) then
if (iand (i - 59, 3) .eq. 0) b(i) = 4 * 256 + i
else if (i .ge. 101 .and. i .le. 125) then
if (mod (i - 101, 12) .eq. 0) b(i) = 5 * 256 + i
end if
end do
 
!$omp parallel num_threads (4)
 
!$omp do
do i = 8, 15
a(i) = 1 * 256 + i
end do
 
!$omp do
do i = 23, 19, -1
a(i) = 2 * 256 + i
end do
 
!$omp do
do i = 28, 39, 2
a(i) = 3 * 256 + i
end do
 
!$omp do
do i = 79, 59, -4
a(i) = 4 * 256 + i
end do
 
!$omp do
do i = 125, 90, -12
a(i) = 5 * 256 + i
end do
 
!$omp end parallel
 
if (any (a .ne. b)) call abort
a = -1
 
!$omp parallel num_threads (4)
 
!$omp do schedule (static)
do i = 8, 15
a(i) = 1 * 256 + i
end do
 
!$omp do schedule (static, 1)
do i = 23, 19, -1
a(i) = 2 * 256 + i
end do
 
!$omp do schedule (static, 3)
do i = 28, 39, 2
a(i) = 3 * 256 + i
end do
 
!$omp do schedule (static, 6)
do i = 79, 59, -4
a(i) = 4 * 256 + i
end do
 
!$omp do schedule (static, 2)
do i = 125, 90, -12
a(i) = 5 * 256 + i
end do
 
!$omp end parallel
 
if (any (a .ne. b)) call abort
a = -1
 
!$omp parallel num_threads (4)
 
!$omp do schedule (dynamic)
do i = 8, 15
a(i) = 1 * 256 + i
end do
 
!$omp do schedule (dynamic, 4)
do i = 23, 19, -1
a(i) = 2 * 256 + i
end do
 
!$omp do schedule (dynamic, 1)
do i = 28, 39, 2
a(i) = 3 * 256 + i
end do
 
!$omp do schedule (dynamic, 2)
do i = 79, 59, -4
a(i) = 4 * 256 + i
end do
 
!$omp do schedule (dynamic, 3)
do i = 125, 90, -12
a(i) = 5 * 256 + i
end do
 
!$omp end parallel
 
if (any (a .ne. b)) call abort
a = -1
 
!$omp parallel num_threads (4)
 
!$omp do schedule (guided)
do i = 8, 15
a(i) = 1 * 256 + i
end do
 
!$omp do schedule (guided, 4)
do i = 23, 19, -1
a(i) = 2 * 256 + i
end do
 
!$omp do schedule (guided, 1)
do i = 28, 39, 2
a(i) = 3 * 256 + i
end do
 
!$omp do schedule (guided, 2)
do i = 79, 59, -4
a(i) = 4 * 256 + i
end do
 
!$omp do schedule (guided, 3)
do i = 125, 90, -12
a(i) = 5 * 256 + i
end do
 
!$omp end parallel
 
if (any (a .ne. b)) call abort
a = -1
 
!$omp parallel num_threads (4)
 
!$omp do schedule (runtime)
do i = 8, 15
a(i) = 1 * 256 + i
end do
 
!$omp do schedule (runtime)
do i = 23, 19, -1
a(i) = 2 * 256 + i
end do
 
!$omp do schedule (runtime)
do i = 28, 39, 2
a(i) = 3 * 256 + i
end do
 
!$omp do schedule (runtime)
do i = 79, 59, -4
a(i) = 4 * 256 + i
end do
 
!$omp do schedule (runtime)
do i = 125, 90, -12
a(i) = 5 * 256 + i
end do
 
!$omp end parallel
 
if (any (a .ne. b)) call abort
end
/pr27416-1.f90
0,0 → 1,19
! PR middle-end/27416
! { dg-do run }
 
integer :: j
j = 6
!$omp parallel num_threads (4)
call foo (j)
!$omp end parallel
if (j.ne.6+16) call abort
end
 
subroutine foo (j)
integer :: i, j
 
!$omp do firstprivate (j) lastprivate (j)
do i = 1, 16
if (i.eq.16) j = j + i
end do
end subroutine foo
/threadprivate2.f90
0,0 → 1,96
! { dg-do run }
! { dg-require-effective-target tls_runtime }
 
module threadprivate2
integer, dimension(:,:), allocatable :: foo
!$omp threadprivate (foo)
end module threadprivate2
 
use omp_lib
use threadprivate2
 
integer, dimension(:), pointer :: bar1
integer, dimension(2), target :: bar2
common /thrc/ bar1, bar2
!$omp threadprivate (/thrc/)
 
integer, dimension(:), pointer, save :: bar3 => NULL()
!$omp threadprivate (bar3)
 
logical :: l
type tt
integer :: a
integer :: b = 32
end type tt
type (tt), save :: baz
!$omp threadprivate (baz)
 
l = .false.
call omp_set_dynamic (.false.)
call omp_set_num_threads (4)
 
!$omp parallel num_threads (4) reduction (.or.:l)
l = allocated (foo)
allocate (foo (6 + omp_get_thread_num (), 3))
l = l.or..not.allocated (foo)
l = l.or.size (foo).ne.(18 + 3 * omp_get_thread_num ())
foo = omp_get_thread_num () + 1
 
bar2 = omp_get_thread_num ()
l = l.or.associated (bar3)
bar1 => bar2
l = l.or..not.associated (bar1)
l = l.or..not.associated (bar1, bar2)
l = l.or.any (bar1.ne.omp_get_thread_num ())
nullify (bar1)
l = l.or.associated (bar1)
allocate (bar3 (4))
l = l.or..not.associated (bar3)
bar3 = omp_get_thread_num () - 2
 
l = l.or.(baz%b.ne.32)
baz%a = omp_get_thread_num () * 2
baz%b = omp_get_thread_num () * 2 + 1
!$omp end parallel
 
if (l) call abort
if (.not.allocated (foo)) call abort
if (size (foo).ne.18) call abort
if (any (foo.ne.1)) call abort
 
if (associated (bar1)) call abort
if (.not.associated (bar3)) call abort
if (any (bar3 .ne. -2)) call abort
deallocate (bar3)
if (associated (bar3)) call abort
 
!$omp parallel num_threads (4) reduction (.or.:l)
l = l.or..not.allocated (foo)
l = l.or.size (foo).ne.(18 + 3 * omp_get_thread_num ())
l = l.or.any (foo.ne.(omp_get_thread_num () + 1))
if (omp_get_thread_num () .ne. 0) then
deallocate (foo)
l = l.or.allocated (foo)
end if
 
l = l.or.associated (bar1)
if (omp_get_thread_num () .ne. 0) then
l = l.or..not.associated (bar3)
l = l.or.any (bar3 .ne. omp_get_thread_num () - 2)
deallocate (bar3)
end if
l = l.or.associated (bar3)
 
l = l.or.(baz%a.ne.(omp_get_thread_num () * 2))
l = l.or.(baz%b.ne.(omp_get_thread_num () * 2 + 1))
!$omp end parallel
 
if (l) call abort
if (.not.allocated (foo)) call abort
if (size (foo).ne.18) call abort
if (any (foo.ne.1)) call abort
deallocate (foo)
if (allocated (foo)) call abort
end
 
! { dg-final { cleanup-modules "threadprivate2" } }
/task2.f90
0,0 → 1,142
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
/do2.f90
0,0 → 1,366
! { dg-do run }
 
integer, dimension (128) :: a, b
integer :: i, j
logical :: k
a = -1
b = -1
do i = 1, 128
if (i .ge. 8 .and. i .le. 15) then
b(i) = 1 * 256 + i
else if (i .ge. 19 .and. i .le. 23) then
b(i) = 2 * 256 + i
else if (i .ge. 28 .and. i .le. 38) then
if (iand (i, 1) .eq. 0) b(i) = 3 * 256 + i
else if (i .ge. 59 .and. i .le. 79) then
if (iand (i - 59, 3) .eq. 0) b(i) = 4 * 256 + i
else if (i .ge. 101 .and. i .le. 125) then
if (mod (i - 101, 12) .eq. 0) b(i) = 5 * 256 + i
end if
end do
 
k = .false.
j = 8
!$omp parallel num_threads (4)
 
!$omp do ordered
do i = 8, 15
a(i) = 1 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j + 1
!$omp end ordered
end do
 
!$omp single
j = 23
!$omp end single
 
!$omp do ordered
do i = 23, 19, -1
a(i) = 2 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 1
!$omp end ordered
end do
 
!$omp single
j = 28
!$omp end single
 
!$omp do ordered
do i = 28, 39, 2
a(i) = 3 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j + 2
!$omp end ordered
end do
 
!$omp single
j = 79
!$omp end single
 
!$omp do ordered
do i = 79, 59, -4
a(i) = 4 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 4
!$omp end ordered
end do
 
!$omp single
j = 125
!$omp end single
 
!$omp do ordered
do i = 125, 90, -12
a(i) = 5 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 12
!$omp end ordered
end do
 
!$omp end parallel
 
if (any (a .ne. b) .or. k) call abort
a = -1
k = .false.
j = 8
!$omp parallel num_threads (4)
 
!$omp do ordered schedule (static)
do i = 8, 15
a(i) = 1 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j + 1
!$omp end ordered
end do
 
!$omp single
j = 23
!$omp end single
 
!$omp do ordered schedule (static, 1)
do i = 23, 19, -1
a(i) = 2 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 1
!$omp end ordered
end do
 
!$omp single
j = 28
!$omp end single
 
!$omp do ordered schedule (static, 3)
do i = 28, 39, 2
a(i) = 3 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j + 2
!$omp end ordered
end do
 
!$omp single
j = 79
!$omp end single
 
!$omp do ordered schedule (static, 6)
do i = 79, 59, -4
a(i) = 4 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 4
!$omp end ordered
end do
 
!$omp single
j = 125
!$omp end single
 
!$omp do ordered schedule (static, 2)
do i = 125, 90, -12
a(i) = 5 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 12
!$omp end ordered
end do
 
!$omp end parallel
 
if (any (a .ne. b) .or. k) call abort
a = -1
k = .false.
j = 8
!$omp parallel num_threads (4)
 
!$omp do ordered schedule (dynamic)
do i = 8, 15
a(i) = 1 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j + 1
!$omp end ordered
end do
 
!$omp single
j = 23
!$omp end single
 
!$omp do ordered schedule (dynamic, 4)
do i = 23, 19, -1
a(i) = 2 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 1
!$omp end ordered
end do
 
!$omp single
j = 28
!$omp end single
 
!$omp do ordered schedule (dynamic, 1)
do i = 28, 39, 2
a(i) = 3 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j + 2
!$omp end ordered
end do
 
!$omp single
j = 79
!$omp end single
 
!$omp do ordered schedule (dynamic, 2)
do i = 79, 59, -4
a(i) = 4 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 4
!$omp end ordered
end do
 
!$omp single
j = 125
!$omp end single
 
!$omp do ordered schedule (dynamic, 3)
do i = 125, 90, -12
a(i) = 5 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 12
!$omp end ordered
end do
 
!$omp end parallel
 
if (any (a .ne. b) .or. k) call abort
a = -1
k = .false.
j = 8
!$omp parallel num_threads (4)
 
!$omp do ordered schedule (guided)
do i = 8, 15
a(i) = 1 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j + 1
!$omp end ordered
end do
 
!$omp single
j = 23
!$omp end single
 
!$omp do ordered schedule (guided, 4)
do i = 23, 19, -1
a(i) = 2 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 1
!$omp end ordered
end do
 
!$omp single
j = 28
!$omp end single
 
!$omp do ordered schedule (guided, 1)
do i = 28, 39, 2
a(i) = 3 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j + 2
!$omp end ordered
end do
 
!$omp single
j = 79
!$omp end single
 
!$omp do ordered schedule (guided, 2)
do i = 79, 59, -4
a(i) = 4 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 4
!$omp end ordered
end do
 
!$omp single
j = 125
!$omp end single
 
!$omp do ordered schedule (guided, 3)
do i = 125, 90, -12
a(i) = 5 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 12
!$omp end ordered
end do
 
!$omp end parallel
 
if (any (a .ne. b) .or. k) call abort
a = -1
k = .false.
j = 8
!$omp parallel num_threads (4)
 
!$omp do ordered schedule (runtime)
do i = 8, 15
a(i) = 1 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j + 1
!$omp end ordered
end do
 
!$omp single
j = 23
!$omp end single
 
!$omp do ordered schedule (runtime)
do i = 23, 19, -1
a(i) = 2 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 1
!$omp end ordered
end do
 
!$omp single
j = 28
!$omp end single
 
!$omp do ordered schedule (runtime)
do i = 28, 39, 2
a(i) = 3 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j + 2
!$omp end ordered
end do
 
!$omp single
j = 79
!$omp end single
 
!$omp do ordered schedule (runtime)
do i = 79, 59, -4
a(i) = 4 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 4
!$omp end ordered
end do
 
!$omp single
j = 125
!$omp end single
 
!$omp do ordered schedule (runtime)
do i = 125, 90, -12
a(i) = 5 * 256 + i
!$omp ordered
if (i .ne. j) k = .true.
j = j - 12
!$omp end ordered
end do
 
!$omp end parallel
 
if (any (a .ne. b) .or. k) call abort
end
/threadprivate3.f90
0,0 → 1,108
! { dg-do run }
! { dg-require-effective-target tls_runtime }
 
module threadprivate3
integer, dimension(:,:), pointer :: foo => NULL()
!$omp threadprivate (foo)
end module threadprivate3
 
use omp_lib
use threadprivate3
 
integer, dimension(:), pointer :: bar1
integer, dimension(2), target :: bar2, var
common /thrc/ bar1, bar2
!$omp threadprivate (/thrc/)
 
integer, dimension(:), pointer, save :: bar3 => NULL()
!$omp threadprivate (bar3)
 
logical :: l
type tt
integer :: a
integer :: b = 32
end type tt
type (tt), save :: baz
!$omp threadprivate (baz)
 
l = .false.
call omp_set_dynamic (.false.)
call omp_set_num_threads (4)
var = 6
 
!$omp parallel num_threads (4) reduction (.or.:l)
bar2 = omp_get_thread_num ()
l = associated (bar3)
bar1 => bar2
l = l.or..not.associated (bar1)
l = l.or..not.associated (bar1, bar2)
l = l.or.any (bar1.ne.omp_get_thread_num ())
nullify (bar1)
l = l.or.associated (bar1)
allocate (bar3 (4))
l = l.or..not.associated (bar3)
bar3 = omp_get_thread_num () - 2
if (omp_get_thread_num () .ne. 0) then
deallocate (bar3)
if (associated (bar3)) call abort
else
bar1 => var
end if
bar2 = omp_get_thread_num () * 6 + 130
 
l = l.or.(baz%b.ne.32)
baz%a = omp_get_thread_num () * 2
baz%b = omp_get_thread_num () * 2 + 1
!$omp end parallel
 
if (l) call abort
if (.not.associated (bar1)) call abort
if (any (bar1.ne.6)) call abort
if (.not.associated (bar3)) call abort
if (any (bar3 .ne. -2)) call abort
deallocate (bar3)
if (associated (bar3)) call abort
 
allocate (bar3 (10))
bar3 = 17
 
!$omp parallel copyin (bar1, bar2, bar3, baz) num_threads (4) &
!$omp& reduction (.or.:l)
l = l.or..not.associated (bar1)
l = l.or.any (bar1.ne.6)
l = l.or.any (bar2.ne.130)
l = l.or..not.associated (bar3)
l = l.or.size (bar3).ne.10
l = l.or.any (bar3.ne.17)
allocate (bar1 (4))
bar1 = omp_get_thread_num ()
bar2 = omp_get_thread_num () + 8
 
l = l.or.(baz%a.ne.0)
l = l.or.(baz%b.ne.1)
baz%a = omp_get_thread_num () * 3 + 4
baz%b = omp_get_thread_num () * 3 + 5
 
!$omp barrier
if (omp_get_thread_num () .eq. 0) then
deallocate (bar3)
end if
bar3 => bar2
!$omp barrier
 
l = l.or..not.associated (bar1)
l = l.or..not.associated (bar3)
l = l.or.any (bar1.ne.omp_get_thread_num ())
l = l.or.size (bar1).ne.4
l = l.or.any (bar2.ne.omp_get_thread_num () + 8)
l = l.or.any (bar3.ne.omp_get_thread_num () + 8)
l = l.or.size (bar3).ne.2
 
l = l.or.(baz%a .ne. omp_get_thread_num () * 3 + 4)
l = l.or.(baz%b .ne. omp_get_thread_num () * 3 + 5)
!$omp end parallel
 
if (l) call abort
end
 
! { dg-final { cleanup-modules "threadprivate3" } }
/condinc2.f
0,0 → 1,7
! { dg-options "-fno-openmp" }
program condinc2
logical l
l = .true.
C$ include 'condinc1.inc'
return
end
/lib1.f90
0,0 → 1,76
! { dg-do run }
 
use omp_lib
 
double precision :: d, e
logical :: l
integer (kind = omp_lock_kind) :: lck
integer (kind = omp_nest_lock_kind) :: nlck
 
d = omp_get_wtime ()
 
call omp_init_lock (lck)
call omp_set_lock (lck)
if (omp_test_lock (lck)) call abort
call omp_unset_lock (lck)
if (.not. omp_test_lock (lck)) call abort
if (omp_test_lock (lck)) call abort
call omp_unset_lock (lck)
call omp_destroy_lock (lck)
 
call omp_init_nest_lock (nlck)
if (omp_test_nest_lock (nlck) .ne. 1) call abort
call omp_set_nest_lock (nlck)
if (omp_test_nest_lock (nlck) .ne. 3) call abort
call omp_unset_nest_lock (nlck)
call omp_unset_nest_lock (nlck)
if (omp_test_nest_lock (nlck) .ne. 2) call abort
call omp_unset_nest_lock (nlck)
call omp_unset_nest_lock (nlck)
call omp_destroy_nest_lock (nlck)
 
call omp_set_dynamic (.true.)
if (.not. omp_get_dynamic ()) call abort
call omp_set_dynamic (.false.)
if (omp_get_dynamic ()) call abort
 
call omp_set_nested (.true.)
if (.not. omp_get_nested ()) call abort
call omp_set_nested (.false.)
if (omp_get_nested ()) call abort
 
call omp_set_num_threads (5)
if (omp_get_num_threads () .ne. 1) call abort
if (omp_get_max_threads () .ne. 5) call abort
if (omp_get_thread_num () .ne. 0) call abort
call omp_set_num_threads (3)
if (omp_get_num_threads () .ne. 1) call abort
if (omp_get_max_threads () .ne. 3) call abort
if (omp_get_thread_num () .ne. 0) call abort
l = .false.
!$omp parallel reduction (.or.:l)
l = omp_get_num_threads () .ne. 3
l = l .or. (omp_get_thread_num () .lt. 0)
l = l .or. (omp_get_thread_num () .ge. 3)
!$omp master
l = l .or. (omp_get_thread_num () .ne. 0)
!$omp end master
!$omp end parallel
if (l) call abort
 
if (omp_get_num_procs () .le. 0) call abort
if (omp_in_parallel ()) call abort
!$omp parallel reduction (.or.:l)
l = .not. omp_in_parallel ()
!$omp end parallel
!$omp parallel reduction (.or.:l) if (.true.)
l = .not. omp_in_parallel ()
!$omp end parallel
 
e = omp_get_wtime ()
if (d .gt. e) call abort
d = omp_get_wtick ()
! Negative precision is definitely wrong,
! bigger than 1s clock resolution is also strange
if (d .le. 0 .or. d .gt. 1.) call abort
end
/nestedfn1.f90
0,0 → 1,43
! { dg-do run }
 
integer :: a, b, c
a = 1
b = 2
c = 3
call foo
if (a .ne. 7) call abort
contains
subroutine foo
use omp_lib
logical :: l
l = .false.
!$omp parallel shared (a) private (b) firstprivate (c) &
!$omp num_threads (2) reduction (.or.:l)
if (a .ne. 1 .or. c .ne. 3) l = .true.
!$omp barrier
if (omp_get_thread_num () .eq. 0) then
a = 4
b = 5
c = 6
end if
!$omp barrier
if (omp_get_thread_num () .eq. 1) then
if (a .ne. 4 .or. c .ne. 3) l = .true.
a = 7
b = 8
c = 9
else if (omp_get_num_threads () .eq. 1) then
a = 7
end if
!$omp barrier
if (omp_get_thread_num () .eq. 0) then
if (a .ne. 7 .or. b .ne. 5 .or. c .ne. 6) l = .true.
end if
!$omp barrier
if (omp_get_thread_num () .eq. 1) then
if (a .ne. 7 .or. b .ne. 8 .or. c .ne. 9) l = .true.
end if
!$omp end parallel
if (l) call abort
end subroutine foo
end
/pr27916-1.f90
0,0 → 1,26
! PR fortran/27916
! Test whether allocatable privatized arrays has "not currently allocated"
! status at the start of OpenMP constructs.
! { dg-do run }
 
program pr27916
integer :: n, i
logical :: r
integer, dimension(:), allocatable :: a
 
r = .false.
!$omp parallel do num_threads (4) private (n, a, i) &
!$omp & reduction (.or.: r) schedule (static)
do n = 1, 16
r = r .or. allocated (a)
allocate (a (16))
r = r .or. .not. allocated (a)
do i = 1, 16
a (i) = i
end do
deallocate (a)
r = r .or. allocated (a)
end do
!$omp end parallel do
if (r) call abort
end program pr27916
/nestedfn2.f90
0,0 → 1,34
! { dg-do run }
 
integer :: i
common /c/ i
i = -1
!$omp parallel shared (i) num_threads (4)
call test1
!$omp end parallel
end
subroutine test1
integer :: vari
call test2
call test3
contains
subroutine test2
use omp_lib
integer :: i
common /c/ i
!$omp single
i = omp_get_thread_num ()
call test4
!$omp end single copyprivate (vari)
end subroutine test2
subroutine test3
integer :: i
common /c/ i
if (i .lt. 0 .or. i .ge. 4) call abort
if (i + 10 .ne. vari) call abort
end subroutine test3
subroutine test4
use omp_lib
vari = omp_get_thread_num () + 10
end subroutine test4
end subroutine test1
/pr27916-2.f90
0,0 → 1,26
! PR fortran/27916
! Test whether allocatable privatized arrays has "not currently allocated"
! status at the start of OpenMP constructs.
! { dg-do run }
 
program pr27916
integer :: n, i
logical :: r
integer, dimension(:), allocatable :: a
 
r = .false.
!$omp parallel do num_threads (4) default (private) &
!$omp & reduction (.or.: r) schedule (static)
do n = 1, 16
r = r .or. allocated (a)
allocate (a (16))
r = r .or. .not. allocated (a)
do i = 1, 16
a (i) = i
end do
deallocate (a)
r = r .or. allocated (a)
end do
!$omp end parallel do
if (r) call abort
end program pr27916
/nestedfn3.f90
0,0 → 1,24
! PR middle-end/28790
! { dg-do run }
 
program nestomp
integer :: j
j = 8
call bar
if (j.ne.10) call abort
contains
subroutine foo (i)
integer :: i
!$omp atomic
j = j + i - 5
end subroutine
subroutine bar
use omp_lib
integer :: i
i = 6
call omp_set_dynamic (.false.)
!$omp parallel num_threads (2)
call foo(i)
!$omp end parallel
end subroutine
end
/nestedfn4.f90
0,0 → 1,41
program foo
integer :: i, j, k
integer :: a(10), c(10)
k = 2
a(:) = 0
call test1
call test2
do i = 1, 10
if (a(i) .ne. 10 * i) call abort
end do
!$omp parallel do reduction (+:c)
do i = 1, 10
c = c + a
end do
do i = 1, 10
if (c(i) .ne. 10 * a(i)) call abort
end do
!$omp parallel do lastprivate (j)
do j = 1, 10, k
end do
if (j .ne. 11) call abort
contains
subroutine test1
integer :: i
integer :: b(10)
do i = 1, 10
b(i) = i
end do
c(:) = 0
!$omp parallel do reduction (+:a)
do i = 1, 10
a = a + b
end do
end subroutine test1
subroutine test2
!$omp parallel do lastprivate (j)
do j = 1, 10, k
end do
if (j .ne. 11) call abort
end subroutine test2
end program foo
/lib4.f90
0,0 → 1,16
! { dg-do run }
 
program lib4
use omp_lib
integer (omp_sched_kind) :: kind
integer :: modifier
call omp_set_schedule (omp_sched_static, 32)
call omp_get_schedule (kind, modifier)
if (kind.ne.omp_sched_static.or.modifier.ne.32) call abort
call omp_set_schedule (omp_sched_dynamic, 4)
call omp_get_schedule (kind, modifier)
if (kind.ne.omp_sched_dynamic.or.modifier.ne.4) call abort
if (omp_get_thread_limit ().lt.0) call abort
call omp_set_max_active_levels (6)
if (omp_get_max_active_levels ().ne.6) call abort
end program lib4
/condinc3.f90
0,0 → 1,7
! { dg-options "-fopenmp" }
program condinc3
logical l
l = .false.
!$ include 'condinc1.inc'
stop 2
end
/condinc4.f90
0,0 → 1,7
! { dg-options "-fno-openmp" }
program condinc4
logical l
l = .true.
!$ include 'condinc1.inc'
return
end
/pr25162.f
0,0 → 1,40
C PR fortran/25162
C { dg-do run }
C { dg-require-effective-target tls_runtime }
PROGRAM PR25162
CALL TEST1
CALL TEST2
END
SUBROUTINE TEST1
DOUBLE PRECISION BPRIM
COMMON /TESTCOM/ BPRIM(100)
C$OMP THREADPRIVATE(/TESTCOM/)
INTEGER I
DO I = 1, 100
BPRIM( I ) = DBLE( I )
END DO
RETURN
END
SUBROUTINE TEST2
DOUBLE PRECISION BPRIM
COMMON /TESTCOM/ BPRIM(100)
C$OMP THREADPRIVATE(/TESTCOM/)
INTEGER I, IDUM(50)
DO I = 1, 50
IDUM(I) = I
END DO
C$OMP PARALLEL COPYIN(/TESTCOM/) NUM_THREADS(4)
CALL TEST3
C$OMP END PARALLEL
RETURN
END
SUBROUTINE TEST3
DOUBLE PRECISION BPRIM
COMMON /TESTCOM/ BPRIM(100)
C$OMP THREADPRIVATE(/TESTCOM/)
INTEGER K
DO K = 1, 10
IF (K.NE.BPRIM(K)) CALL ABORT
END DO
RETURN
END
/pr28390.f
0,0 → 1,8
! PR fortran/28390
program pr28390
integer i
!$omp parallel do lastprivate(i)
do i=1,100
end do
if (i.ne.101) call abort
end
/reference1.f90
0,0 → 1,34
! { dg-do run }
!$ use omp_lib
 
integer :: i, j, k
double precision :: d
i = 6
j = 19
k = 0
d = 24.5
call test (i, j, k, d)
if (i .ne. 38) call abort
if (iand (k, 255) .ne. 0) call abort
if (iand (k, 65280) .eq. 0) then
if (k .ne. 65536 * 4) call abort
end if
contains
subroutine test (i, j, k, d)
integer :: i, j, k
double precision :: d
 
!$omp parallel firstprivate (d) private (j) num_threads (4) reduction (+:k)
if (i .ne. 6 .or. d .ne. 24.5 .or. k .ne. 0) k = k + 1
if (omp_get_num_threads () .ne. 4) k = k + 256
d = d / 2
j = 8
k = k + 65536
!$omp barrier
if (d .ne. 12.25 .or. j .ne. 8) k = k + 1
!$omp single
i = i + 32
!$omp end single nowait
!$omp end parallel
end subroutine test
end
/reference2.f90
0,0 → 1,21
! { dg-do run }
real, dimension (5) :: b
b = 5
call foo (b)
contains
subroutine foo (a)
real, dimension (5) :: a
logical :: l
l = .false.
!$omp parallel private (a) reduction (.or.:l)
a = 15
l = bar (a)
!$omp end parallel
if (l) call abort
end subroutine
function bar (a)
real, dimension (5) :: a
logical :: bar
bar = any (a .ne. 15)
end function
end
/collapse1.f90
0,0 → 1,26
! { dg-do run }
 
program collapse1
integer :: i, j, k, a(1:3, 4:6, 5:7)
logical :: l
l = .false.
a(:, :, :) = 0
!$omp parallel do collapse(4 - 1) schedule(static, 4)
do i = 1, 3
do j = 4, 6
do k = 5, 7
a(i, j, k) = i + j + k
end do
end do
end do
!$omp parallel do collapse(2) reduction(.or.:l)
do i = 1, 3
do j = 4, 6
do k = 5, 7
if (a(i, j, k) .ne. (i + j + k)) l = .true.
end do
end do
end do
!$omp end parallel do
if (l) call abort
end program collapse1
/collapse2.f90
0,0 → 1,53
! { dg-do run }
 
program collapse2
call test1
call test2
contains
subroutine test1
integer :: i, j, k, a(1:3, 4:6, 5:7)
logical :: l
l = .false.
a(:, :, :) = 0
!$omp parallel do collapse(4 - 1) schedule(static, 4)
do 164 i = 1, 3
do 164 j = 4, 6
do 164 k = 5, 7
a(i, j, k) = i + j + k
164 end do
!$omp parallel do collapse(2) reduction(.or.:l)
firstdo: do i = 1, 3
do j = 4, 6
do k = 5, 7
if (a(i, j, k) .ne. (i + j + k)) l = .true.
end do
end do
end do firstdo
!$omp end parallel do
if (l) call abort
end subroutine test1
 
subroutine test2
integer :: a(3,3,3), k, kk, kkk, l, ll, lll
!$omp do collapse(3)
do 115 k=1,3
dokk: do kk=1,3
do kkk=1,3
a(k,kk,kkk) = 1
enddo
enddo dokk
115 continue
if (any(a(1:3,1:3,1:3).ne.1)) call abort
 
!$omp do collapse(3)
dol: do 120 l=1,3
doll: do ll=1,3
do lll=1,3
a(l,ll,lll) = 2
enddo
enddo doll
120 end do dol
if (any(a(1:3,1:3,1:3).ne.2)) call abort
end subroutine test2
 
end program collapse2
/collapse3.f90
0,0 → 1,204
! { dg-do run }
 
program collapse3
call test1
call test2 (2, 6, -2, 4, 13, 18)
call test3 (2, 6, -2, 4, 13, 18, 1, 1, 1)
call test4
call test5 (2, 6, -2, 4, 13, 18)
call test6 (2, 6, -2, 4, 13, 18, 1, 1, 1)
contains
subroutine test1
integer :: i, j, k, a(1:7, -3:5, 12:19), m
logical :: l
l = .false.
a(:, :, :) = 0
!$omp parallel do collapse (3) lastprivate (i, j, k, m) reduction (.or.:l)
do i = 2, 6
do j = -2, 4
do k = 13, 18
l = l.or.i.lt.2.or.i.gt.6.or.j.lt.-2.or.j.gt.4
l = l.or.k.lt.13.or.k.gt.18
if (.not.l) a(i, j, k) = a(i, j, k) + 1
m = i * 100 + j * 10 + k
end do
end do
end do
if (i.ne.7.or.j.ne.5.or.k.ne.19) call abort
if (m.ne.(600+40+18)) call abort
do i = 1, 7
do j = -3, 5
do k = 12, 19
if (i.eq.1.or.i.eq.7.or.j.eq.-3.or.j.eq.5.or.k.eq.12.or.k.eq.19) then
if (a(i, j, k).ne.0) print *, i, j, k
else
if (a(i, j, k).ne.1) print *, 'kk', i, j, k, a(i, j, k)
end if
end do
end do
end do
end subroutine test1
 
subroutine test2(v1, v2, v3, v4, v5, v6)
integer :: i, j, k, a(1:7, -3:5, 12:19), m
integer :: v1, v2, v3, v4, v5, v6
logical :: l
l = .false.
a(:, :, :) = 0
!$omp parallel do collapse (3) lastprivate (i, j, k, m) reduction (.or.:l)
do i = v1, v2
do j = v3, v4
do k = v5, v6
l = l.or.i.lt.2.or.i.gt.6.or.j.lt.-2.or.j.gt.4
l = l.or.k.lt.13.or.k.gt.18
if (.not.l) a(i, j, k) = a(i, j, k) + 1
m = i * 100 + j * 10 + k
end do
end do
end do
if (i.ne.7.or.j.ne.5.or.k.ne.19) call abort
if (m.ne.(600+40+18)) call abort
do i = 1, 7
do j = -3, 5
do k = 12, 19
if (i.eq.1.or.i.eq.7.or.j.eq.-3.or.j.eq.5.or.k.eq.12.or.k.eq.19) then
if (a(i, j, k).ne.0) print *, i, j, k
else
if (a(i, j, k).ne.1) print *, 'kk', i, j, k, a(i, j, k)
end if
end do
end do
end do
end subroutine test2
 
subroutine test3(v1, v2, v3, v4, v5, v6, v7, v8, v9)
integer :: i, j, k, a(1:7, -3:5, 12:19), m
integer :: v1, v2, v3, v4, v5, v6, v7, v8, v9
logical :: l
l = .false.
a(:, :, :) = 0
!$omp parallel do collapse (3) lastprivate (i, j, k, m) reduction (.or.:l)
do i = v1, v2, v7
do j = v3, v4, v8
do k = v5, v6, v9
l = l.or.i.lt.2.or.i.gt.6.or.j.lt.-2.or.j.gt.4
l = l.or.k.lt.13.or.k.gt.18
if (.not.l) a(i, j, k) = a(i, j, k) + 1
m = i * 100 + j * 10 + k
end do
end do
end do
if (i.ne.7.or.j.ne.5.or.k.ne.19) call abort
if (m.ne.(600+40+18)) call abort
do i = 1, 7
do j = -3, 5
do k = 12, 19
if (i.eq.1.or.i.eq.7.or.j.eq.-3.or.j.eq.5.or.k.eq.12.or.k.eq.19) then
if (a(i, j, k).ne.0) print *, i, j, k
else
if (a(i, j, k).ne.1) print *, 'kk', i, j, k, a(i, j, k)
end if
end do
end do
end do
end subroutine test3
 
subroutine test4
integer :: i, j, k, a(1:7, -3:5, 12:19), m
logical :: l
l = .false.
a(:, :, :) = 0
!$omp parallel do collapse (3) lastprivate (i, j, k, m) reduction (.or.:l) &
!$omp& schedule (dynamic, 5)
do i = 2, 6
do j = -2, 4
do k = 13, 18
l = l.or.i.lt.2.or.i.gt.6.or.j.lt.-2.or.j.gt.4
l = l.or.k.lt.13.or.k.gt.18
if (.not.l) a(i, j, k) = a(i, j, k) + 1
m = i * 100 + j * 10 + k
end do
end do
end do
if (i.ne.7.or.j.ne.5.or.k.ne.19) call abort
if (m.ne.(600+40+18)) call abort
do i = 1, 7
do j = -3, 5
do k = 12, 19
if (i.eq.1.or.i.eq.7.or.j.eq.-3.or.j.eq.5.or.k.eq.12.or.k.eq.19) then
if (a(i, j, k).ne.0) print *, i, j, k
else
if (a(i, j, k).ne.1) print *, 'kk', i, j, k, a(i, j, k)
end if
end do
end do
end do
end subroutine test4
 
subroutine test5(v1, v2, v3, v4, v5, v6)
integer :: i, j, k, a(1:7, -3:5, 12:19), m
integer :: v1, v2, v3, v4, v5, v6
logical :: l
l = .false.
a(:, :, :) = 0
!$omp parallel do collapse (3) lastprivate (i, j, k, m) reduction (.or.:l) &
!$omp & schedule (guided)
do i = v1, v2
do j = v3, v4
do k = v5, v6
l = l.or.i.lt.2.or.i.gt.6.or.j.lt.-2.or.j.gt.4
l = l.or.k.lt.13.or.k.gt.18
if (.not.l) a(i, j, k) = a(i, j, k) + 1
m = i * 100 + j * 10 + k
end do
end do
end do
if (i.ne.7.or.j.ne.5.or.k.ne.19) call abort
if (m.ne.(600+40+18)) call abort
do i = 1, 7
do j = -3, 5
do k = 12, 19
if (i.eq.1.or.i.eq.7.or.j.eq.-3.or.j.eq.5.or.k.eq.12.or.k.eq.19) then
if (a(i, j, k).ne.0) print *, i, j, k
else
if (a(i, j, k).ne.1) print *, 'kk', i, j, k, a(i, j, k)
end if
end do
end do
end do
end subroutine test5
 
subroutine test6(v1, v2, v3, v4, v5, v6, v7, v8, v9)
integer :: i, j, k, a(1:7, -3:5, 12:19), m
integer :: v1, v2, v3, v4, v5, v6, v7, v8, v9
logical :: l
l = .false.
a(:, :, :) = 0
!$omp parallel do collapse (3) lastprivate (i, j, k, m) reduction (.or.:l) &
!$omp & schedule (dynamic)
do i = v1, v2, v7
do j = v3, v4, v8
do k = v5, v6, v9
l = l.or.i.lt.2.or.i.gt.6.or.j.lt.-2.or.j.gt.4
l = l.or.k.lt.13.or.k.gt.18
if (.not.l) a(i, j, k) = a(i, j, k) + 1
m = i * 100 + j * 10 + k
end do
end do
end do
if (i.ne.7.or.j.ne.5.or.k.ne.19) call abort
if (m.ne.(600+40+18)) call abort
do i = 1, 7
do j = -3, 5
do k = 12, 19
if (i.eq.1.or.i.eq.7.or.j.eq.-3.or.j.eq.5.or.k.eq.12.or.k.eq.19) then
if (a(i, j, k).ne.0) print *, i, j, k
else
if (a(i, j, k).ne.1) print *, 'kk', i, j, k, a(i, j, k)
end if
end do
end do
end do
end subroutine test6
 
end program collapse3
/collapse4.f90
0,0 → 1,12
! { dg-do run }
 
integer :: i, j, k
!$omp parallel do lastprivate (i, j, k) collapse (3)
do i = 0, 17
do j = 0, 6
do k = 0, 5
end do
end do
end do
if (i .ne. 18 .or. j .ne. 7 .or. k .ne. 6) call abort
end
/lock-1.f90
0,0 → 1,24
! { dg-do run }
 
use omp_lib
 
integer (kind = omp_nest_lock_kind) :: lock
logical :: l
 
l = .false.
call omp_init_nest_lock (lock)
if (omp_test_nest_lock (lock) .ne. 1) call abort
if (omp_test_nest_lock (lock) .ne. 2) call abort
!$omp parallel if (.false.) reduction (.or.:l)
! In OpenMP 2.5 this was supposed to return 3,
! but in OpenMP 3.0 the parallel region has a different
! task and omp_*_lock_t are owned by tasks, not by threads.
if (omp_test_nest_lock (lock) .ne. 0) l = .true.
!$omp end parallel
if (l) call abort
if (omp_test_nest_lock (lock) .ne. 3) call abort
call omp_unset_nest_lock (lock)
call omp_unset_nest_lock (lock)
call omp_unset_nest_lock (lock)
call omp_destroy_nest_lock (lock)
end
/lock-2.f90
0,0 → 1,24
! { dg-do run }
 
use omp_lib
 
integer (kind = omp_nest_lock_kind) :: lock
logical :: l
 
l = .false.
call omp_init_nest_lock (lock)
!$omp parallel num_threads (1) reduction (.or.:l)
if (omp_test_nest_lock (lock) .ne. 1) call abort
if (omp_test_nest_lock (lock) .ne. 2) call abort
!$omp task if (.false.) shared (lock, l)
if (omp_test_nest_lock (lock) .ne. 0) l = .true.
!$omp end task
!$omp taskwait
if (omp_test_nest_lock (lock) .ne. 3) l = .true.
call omp_unset_nest_lock (lock)
call omp_unset_nest_lock (lock)
call omp_unset_nest_lock (lock)
!$omp end parallel
if (l) call abort
call omp_destroy_nest_lock (lock)
end
/omp_workshare1.f
0,0 → 1,48
C******************************************************************************
C FILE: omp_workshare1.f
C DESCRIPTION:
C OpenMP Example - Loop Work-sharing - Fortran Version
C In this example, the iterations of a loop are scheduled dynamically
C across the team of threads. A thread will perform CHUNK iterations
C at a time before being scheduled for the next CHUNK of work.
C AUTHOR: Blaise Barney 5/99
C LAST REVISED: 01/09/04
C******************************************************************************
 
PROGRAM WORKSHARE1
 
INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS,
+ OMP_GET_THREAD_NUM, N, CHUNKSIZE, CHUNK, I
PARAMETER (N=100)
PARAMETER (CHUNKSIZE=10)
REAL A(N), B(N), C(N)
 
! Some initializations
DO I = 1, N
A(I) = I * 1.0
B(I) = A(I)
ENDDO
CHUNK = CHUNKSIZE
 
!$OMP PARALLEL SHARED(A,B,C,NTHREADS,CHUNK) PRIVATE(I,TID)
 
TID = OMP_GET_THREAD_NUM()
IF (TID .EQ. 0) THEN
NTHREADS = OMP_GET_NUM_THREADS()
PRINT *, 'Number of threads =', NTHREADS
END IF
PRINT *, 'Thread',TID,' starting...'
 
!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
DO I = 1, N
C(I) = A(I) + B(I)
WRITE(*,100) TID,I,C(I)
100 FORMAT(' Thread',I2,': C(',I3,')=',F8.2)
ENDDO
!$OMP END DO NOWAIT
 
PRINT *, 'Thread',TID,' done.'
 
!$OMP END PARALLEL
 
END
/omp_orphan.f
0,0 → 1,44
C******************************************************************************
C FILE: omp_orphan.f
C DESCRIPTION:
C OpenMP Example - Parallel region with an orphaned directive - Fortran
C Version
C This example demonstrates a dot product being performed by an orphaned
C loop reduction construct. Scoping of the reduction variable is critical.
C AUTHOR: Blaise Barney 5/99
C LAST REVISED:
C******************************************************************************
 
PROGRAM ORPHAN
COMMON /DOTDATA/ A, B, SUM
INTEGER I, VECLEN
PARAMETER (VECLEN = 100)
REAL*8 A(VECLEN), B(VECLEN), SUM
 
DO I=1, VECLEN
A(I) = 1.0 * I
B(I) = A(I)
ENDDO
SUM = 0.0
!$OMP PARALLEL
CALL DOTPROD
!$OMP END PARALLEL
WRITE(*,*) "Sum = ", SUM
END
 
 
 
SUBROUTINE DOTPROD
COMMON /DOTDATA/ A, B, SUM
INTEGER I, TID, OMP_GET_THREAD_NUM, VECLEN
PARAMETER (VECLEN = 100)
REAL*8 A(VECLEN), B(VECLEN), SUM
 
TID = OMP_GET_THREAD_NUM()
!$OMP DO REDUCTION(+:SUM)
DO I=1, VECLEN
SUM = SUM + (A(I)*B(I))
PRINT *, ' TID= ',TID,'I= ',I
ENDDO
RETURN
END
/tabs2.f
0,0 → 1,13
! { dg-options "-ffixed-form" }
if (b().ne.2) call abort
contains
subroutine a
!$omp parallel
!$omp end parallel
end subroutine a
function b()
integer :: b
b = 1
!$ b = 2
end function b
end
/nested1.f90
0,0 → 1,87
! { dg-do run }
program nested1
use omp_lib
integer :: e1, e2, e3, e
integer :: tn1, tn2, tn3
e1 = 0
e2 = 0
e3 = 0
call omp_set_nested (.true.)
call omp_set_dynamic (.false.)
if (omp_in_parallel ()) call abort
if (omp_get_num_threads ().ne.1) call abort
if (omp_get_level ().ne.0) call abort
if (omp_get_ancestor_thread_num (0).ne.0) call abort
if (omp_get_ancestor_thread_num (-1).ne.-1) call abort
if (omp_get_ancestor_thread_num (1).ne.-1) call abort
if (omp_get_team_size (0).ne.1) call abort
if (omp_get_team_size (-1).ne.-1) call abort
if (omp_get_team_size (1).ne.-1) call abort
if (omp_get_active_level ().ne.0) call abort
!$omp parallel num_threads (4) private (e, tn1)
e = 0
tn1 = omp_get_thread_num ()
if (.not.omp_in_parallel ()) e = e + 1
if (omp_get_num_threads ().ne.4) e = e + 1
if (tn1.lt.0.or.tn1.ge.4) e = e + 1
if (omp_get_level ().ne.1) e = e + 1
if (omp_get_ancestor_thread_num (0).ne.0) e = e + 1
if (omp_get_ancestor_thread_num (1).ne.tn1) e = e + 1
if (omp_get_ancestor_thread_num (-1).ne.-1) e = e + 1
if (omp_get_ancestor_thread_num (2).ne.-1) e = e + 1
if (omp_get_team_size (0).ne.1) e = e + 1
if (omp_get_team_size (1).ne.4) e = e + 1
if (omp_get_team_size (-1).ne.-1) e = e + 1
if (omp_get_team_size (2).ne.-1) e = e + 1
if (omp_get_active_level ().ne.1) e = e + 1
!$omp atomic
e1 = e1 + e
!$omp parallel num_threads (5) if (.false.) firstprivate (tn1) &
!$omp& private (e, tn2)
e = 0
tn2 = omp_get_thread_num ()
if (.not.omp_in_parallel ()) e = e + 1
if (omp_get_num_threads ().ne.1) e = e + 1
if (tn2.ne.0) e = e + 1
if (omp_get_level ().ne.2) e = e + 1
if (omp_get_ancestor_thread_num (0).ne.0) e = e + 1
if (omp_get_ancestor_thread_num (1).ne.tn1) e = e + 1
if (omp_get_ancestor_thread_num (2).ne.tn2) e = e + 1
if (omp_get_ancestor_thread_num (-1).ne.-1) e = e + 1
if (omp_get_ancestor_thread_num (3).ne.-1) e = e + 1
if (omp_get_team_size (0).ne.1) e = e + 1
if (omp_get_team_size (1).ne.4) e = e + 1
if (omp_get_team_size (2).ne.1) e = e + 1
if (omp_get_team_size (-1).ne.-1) e = e + 1
if (omp_get_team_size (3).ne.-1) e = e + 1
if (omp_get_active_level ().ne.1) e = e + 1
!$omp atomic
e2 = e2 + e
!$omp parallel num_threads (2) firstprivate (tn1, tn2) &
!$omp& private (e, tn3)
e = 0
tn3 = omp_get_thread_num ()
if (.not.omp_in_parallel ()) e = e + 1
if (omp_get_num_threads ().ne.2) e = e + 1
if (tn3.lt.0.or.tn3.ge.2) e = e + 1
if (omp_get_level ().ne.3) e = e + 1
if (omp_get_ancestor_thread_num (0).ne.0) e = e + 1
if (omp_get_ancestor_thread_num (1).ne.tn1) e = e + 1
if (omp_get_ancestor_thread_num (2).ne.tn2) e = e + 1
if (omp_get_ancestor_thread_num (3).ne.tn3) e = e + 1
if (omp_get_ancestor_thread_num (-1).ne.-1) e = e + 1
if (omp_get_ancestor_thread_num (4).ne.-1) e = e + 1
if (omp_get_team_size (0).ne.1) e = e + 1
if (omp_get_team_size (1).ne.4) e = e + 1
if (omp_get_team_size (2).ne.1) e = e + 1
if (omp_get_team_size (3).ne.2) e = e + 1
if (omp_get_team_size (-1).ne.-1) e = e + 1
if (omp_get_team_size (4).ne.-1) e = e + 1
if (omp_get_active_level ().ne.2) e = e + 1
!$omp atomic
e3 = e3 + e
!$omp end parallel
!$omp end parallel
!$omp end parallel
if (e1.ne.0.or.e2.ne.0.or.e3.ne.0) call abort
end program nested1
/omp_hello.f
0,0 → 1,36
C******************************************************************************
C FILE: omp_hello.f
C DESCRIPTION:
C OpenMP Example - Hello World - Fortran Version
C In this simple example, the master thread forks a parallel region.
C All threads in the team obtain their unique thread number and print it.
C The master thread only prints the total number of threads. Two OpenMP
C library routines are used to obtain the number of threads and each
C thread's number.
C AUTHOR: Blaise Barney 5/99
C LAST REVISED:
C******************************************************************************
 
PROGRAM HELLO
 
INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS,
+ OMP_GET_THREAD_NUM
 
C Fork a team of threads giving them their own copies of variables
!$OMP PARALLEL PRIVATE(NTHREADS, TID)
 
 
C Obtain thread number
TID = OMP_GET_THREAD_NUM()
PRINT *, 'Hello World from thread = ', TID
 
C Only master thread does this
IF (TID .EQ. 0) THEN
NTHREADS = OMP_GET_NUM_THREADS()
PRINT *, 'Number of threads = ', NTHREADS
END IF
 
C All threads join master thread and disband
!$OMP END PARALLEL
 
END
/omp_cond2.f
0,0 → 1,22
c Test conditional compilation in fixed form if -fno-openmp
! { dg-options "-fno-openmp" }
10 foo = 2
&56
if (foo.ne.256) call abort
bar = 26
!$2 0 ba
c$ +r = 42
!$ bar = 62
!$ bar = bar + 1
if (bar.ne.26) call abort
baz = bar
*$ 0baz = 5
C$ +12! Comment
c$ !4
!$ +!Another comment
*$ &2
!$ X baz = 0 ! Not valid OpenMP conditional compilation lines
! $ baz = 1
c$ 10&baz = 2
if (baz.ne.26) call abort
end
/omp_atomic1.f90
0,0 → 1,39
! { dg-do run }
integer (kind = 4) :: a
integer (kind = 2) :: b
real :: c, f
double precision :: d
integer, dimension (10) :: e
a = 1
b = 2
c = 3
d = 4
e = 5
f = 6
!$omp atomic
a = a + 4
!$omp atomic
b = 4 - b
!$omp atomic
c = c * 2
!$omp atomic
d = 2 / d
if (a .ne. 5 .or. b .ne. 2 .or. c .ne. 6 .or. d .ne. 0.5) call abort
d = 1.2
!$omp atomic
a = a + c + d
!$omp atomic
b = b - (a + c + d)
if (a .ne. 12 .or. b .ne. -17) call abort
!$omp atomic
a = c + d + a
!$omp atomic
b = a + c + d - b
if (a .ne. 19 .or. b .ne. 43) call abort
!$omp atomic
b = (a + c + d) - b
a = 32
!$omp atomic
a = a / 3.4
if (a .ne. 9 .or. b .ne. -16) call abort
end
/omp_atomic2.f90
0,0 → 1,54
! { dg-do run }
real, dimension (20) :: r
integer, dimension (20) :: d
integer :: i, j, k, n
integer (kind = 2) :: a, b, c
 
do 10 i = 1, 20
r(i) = i
10 d(i) = 21 - i
 
n = 20
call foo (r, d, n)
 
if (n .ne. 22) call abort
if (any (r .ne. 33)) call abort
 
i = 1
j = 18
k = 23
!$omp atomic
i = min (i, j, k, n)
if (i .ne. 1) call abort
!$omp atomic
i = max (j, n, k, i)
if (i .ne. 23) call abort
 
a = 1
b = 18
c = 23
!$omp atomic
a = min (a, b, c)
if (a .ne. 1) call abort
!$omp atomic
a = max (a, b, c)
if (a .ne. 23) call abort
 
contains
function bar (i)
real bar
integer i
bar = 12.0 + i
end function bar
 
subroutine foo (x, y, n)
integer i, y (*), n
real x (*)
do i = 1, n
!$omp atomic
x(y(i)) = x(y(i)) + bar (i)
end do
!$omp atomic
n = n + 2
end subroutine foo
end
/fortran.exp
0,0 → 1,51
load_lib libgomp-dg.exp
 
global shlib_ext
 
set shlib_ext [get_shlib_extension]
set lang_library_path "../libgfortran/.libs"
set lang_link_flags "-lgfortran"
set lang_test_file_found 0
 
 
# Initialize dg.
dg-init
 
if { $blddir != "" } {
# Look for a static libgfortran first.
if [file exists "${blddir}/${lang_library_path}/libgfortran.a"] {
set lang_test_file "${lang_library_path}/libgfortran.a"
set lang_test_file_found 1
# We may have a shared only build, so look for a shared libgfortran.
} elseif [file exists "${blddir}/${lang_library_path}/libgfortran.${shlib_ext}"] {
set lang_test_file "${lang_library_path}/libgfortran.${shlib_ext}"
set lang_test_file_found 1
} else {
puts "No libgfortran library found, will not execute fortran tests"
}
} elseif [info exists GFORTRAN_UNDER_TEST] {
set lang_test_file_found 1
# Needs to exist for libgomp.exp.
set lang_test_file ""
} else {
puts "GFORTRAN_UNDER_TEST not defined, will not execute fortran tests"
}
 
if { $lang_test_file_found } {
# Gather a list of all tests.
set tests [lsort [find $srcdir/$subdir *.\[fF\]{,90,95,03,08}]]
 
if { $blddir != "" } {
set ld_library_path "$always_ld_library_path:${blddir}/${lang_library_path}"
} else {
set ld_library_path "$always_ld_library_path"
}
append ld_library_path [gcc-set-multilib-library-path $GCC_UNDER_TEST]
set_ld_library_path_env_vars
 
# Main loop.
gfortran-dg-runtest $tests ""
}
 
# All done.
dg-finish
/tabs1.f90
0,0 → 1,12
if (b().ne.2) call abort
contains
subroutine a
!$omp parallel
!$omp end parallel
end subroutine a
function b()
integer :: b
b = 1
!$ b = 2
end function b
end
/sharing1.f90
0,0 → 1,29
! { dg-do run }
 
use omp_lib
integer :: i, j, k
logical :: l
common /b/ i, j
i = 4
j = 8
l = .false.
!$omp parallel private (k) firstprivate (i) shared (j) num_threads (2) &
!$omp& reduction (.or.:l)
if (i .ne. 4 .or. j .ne. 8) l = .true.
!$omp barrier
k = omp_get_thread_num ()
if (k .eq. 0) then
i = 14
j = 15
end if
!$omp barrier
if (k .eq. 1) then
if (i .ne. 4 .or. j .ne. 15) l = .true.
i = 24
j = 25
end if
!$omp barrier
if (j .ne. 25 .or. i .ne. (k * 10 + 14)) l = .true.
!$omp end parallel
if (l .or. j .ne. 25) call abort
end
/pr35130.f90
0,0 → 1,20
! PR middle-end/35130
 
program pr35130
implicit none
real, dimension(20) :: a
integer :: k
a(:) = 0.0
!$omp parallel do private(k)
do k=1,size(a)
call inner(k)
end do
!$omp end parallel do
if (any (a.ne.42)) call abort
contains
subroutine inner(i)
implicit none
integer :: i
a(i) = 42
end subroutine inner
end program pr35130
/sharing2.f90
0,0 → 1,32
! { dg-do run }
 
use omp_lib
integer :: i, j, k, m, n
logical :: l
equivalence (i, m)
equivalence (j, n)
i = 4
j = 8
l = .false.
!$omp parallel private (k) firstprivate (i) shared (j) num_threads (2) &
!$omp& reduction (.or.:l)
l = l .or. i .ne. 4
l = l .or. j .ne. 8
!$omp barrier
k = omp_get_thread_num ()
if (k .eq. 0) then
i = 14
j = 15
end if
!$omp barrier
if (k .eq. 1) then
if (i .ne. 4 .or. j .ne. 15) l = .true.
i = 24
j = 25
end if
!$omp barrier
if (j .ne. 25 .or. i .ne. (k * 10 + 14)) l = .true.
!$omp end parallel
if (l) call abort
if (j .ne. 25) call abort
end
/lastprivate1.f90
0,0 → 1,126
program lastprivate
integer :: i
common /c/ i
!$omp parallel num_threads (4)
call test1
!$omp end parallel
if (i .ne. 21) call abort
!$omp parallel num_threads (4)
call test2
!$omp end parallel
if (i .ne. 64) call abort
!$omp parallel num_threads (4)
call test3
!$omp end parallel
if (i .ne. 14) call abort
call test4
call test5
call test6
call test7
call test8
call test9
call test10
call test11
call test12
contains
subroutine test1
integer :: i
common /c/ i
!$omp do lastprivate (i)
do i = 1, 20
end do
end subroutine test1
subroutine test2
integer :: i
common /c/ i
!$omp do lastprivate (i)
do i = 7, 61, 3
end do
end subroutine test2
function ret3 ()
integer :: ret3
ret3 = 3
end function ret3
subroutine test3
integer :: i
common /c/ i
!$omp do lastprivate (i)
do i = -10, 11, ret3 ()
end do
end subroutine test3
subroutine test4
integer :: j
!$omp parallel do lastprivate (j) num_threads (4) default (none)
do j = 1, 20
end do
if (j .ne. 21) call abort
end subroutine test4
subroutine test5
integer :: j
!$omp parallel do lastprivate (j) num_threads (4) default (none)
do j = 7, 61, 3
end do
if (j .ne. 64) call abort
end subroutine test5
subroutine test6
integer :: j
!$omp parallel do lastprivate (j) num_threads (4) default (none)
do j = -10, 11, ret3 ()
end do
if (j .ne. 14) call abort
end subroutine test6
subroutine test7
integer :: i
common /c/ i
!$omp parallel do lastprivate (i) num_threads (4) default (none)
do i = 1, 20
end do
if (i .ne. 21) call abort
end subroutine test7
subroutine test8
integer :: i
common /c/ i
!$omp parallel do lastprivate (i) num_threads (4) default (none)
do i = 7, 61, 3
end do
if (i .ne. 64) call abort
end subroutine test8
subroutine test9
integer :: i
common /c/ i
!$omp parallel do lastprivate (i) num_threads (4) default (none)
do i = -10, 11, ret3 ()
end do
if (i .ne. 14) call abort
end subroutine test9
subroutine test10
integer :: i
common /c/ i
!$omp parallel num_threads (4) default (none) shared (i)
!$omp do lastprivate (i)
do i = 1, 20
end do
!$omp end parallel
if (i .ne. 21) call abort
end subroutine test10
subroutine test11
integer :: i
common /c/ i
!$omp parallel num_threads (4) default (none) shared (i)
!$omp do lastprivate (i)
do i = 7, 61, 3
end do
!$omp end parallel
if (i .ne. 64) call abort
end subroutine test11
subroutine test12
integer :: i
common /c/ i
!$omp parallel num_threads (4) default (none) shared (i)
!$omp do lastprivate (i)
do i = -10, 11, ret3 ()
end do
!$omp end parallel
if (i .ne. 14) call abort
end subroutine test12
end program lastprivate
/lib2.f
0,0 → 1,76
C { dg-do run }
 
USE OMP_LIB
 
DOUBLE PRECISION :: D, E
LOGICAL :: L
INTEGER (KIND = OMP_LOCK_KIND) :: LCK
INTEGER (KIND = OMP_NEST_LOCK_KIND) :: NLCK
 
D = OMP_GET_WTIME ()
 
CALL OMP_INIT_LOCK (LCK)
CALL OMP_SET_LOCK (LCK)
IF (OMP_TEST_LOCK (LCK)) CALL ABORT
CALL OMP_UNSET_LOCK (LCK)
IF (.NOT. OMP_TEST_LOCK (LCK)) CALL ABORT
IF (OMP_TEST_LOCK (LCK)) CALL ABORT
CALL OMP_UNSET_LOCK (LCK)
CALL OMP_DESTROY_LOCK (LCK)
 
CALL OMP_INIT_NEST_LOCK (NLCK)
IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 1) CALL ABORT
CALL OMP_SET_NEST_LOCK (NLCK)
IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 3) CALL ABORT
CALL OMP_UNSET_NEST_LOCK (NLCK)
CALL OMP_UNSET_NEST_LOCK (NLCK)
IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 2) CALL ABORT
CALL OMP_UNSET_NEST_LOCK (NLCK)
CALL OMP_UNSET_NEST_LOCK (NLCK)
CALL OMP_DESTROY_NEST_LOCK (NLCK)
 
CALL OMP_SET_DYNAMIC (.TRUE.)
IF (.NOT. OMP_GET_DYNAMIC ()) CALL ABORT
CALL OMP_SET_DYNAMIC (.FALSE.)
IF (OMP_GET_DYNAMIC ()) CALL ABORT
 
CALL OMP_SET_NESTED (.TRUE.)
IF (.NOT. OMP_GET_NESTED ()) CALL ABORT
CALL OMP_SET_NESTED (.FALSE.)
IF (OMP_GET_NESTED ()) CALL ABORT
 
CALL OMP_SET_NUM_THREADS (5)
IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT
IF (OMP_GET_MAX_THREADS () .NE. 5) CALL ABORT
IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT
CALL OMP_SET_NUM_THREADS (3)
IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT
IF (OMP_GET_MAX_THREADS () .NE. 3) CALL ABORT
IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT
L = .FALSE.
C$OMP PARALLEL REDUCTION (.OR.:L)
L = OMP_GET_NUM_THREADS () .NE. 3
L = L .OR. (OMP_GET_THREAD_NUM () .LT. 0)
L = L .OR. (OMP_GET_THREAD_NUM () .GE. 3)
C$OMP MASTER
L = L .OR. (OMP_GET_THREAD_NUM () .NE. 0)
C$OMP END MASTER
C$OMP END PARALLEL
IF (L) CALL ABORT
 
IF (OMP_GET_NUM_PROCS () .LE. 0) CALL ABORT
IF (OMP_IN_PARALLEL ()) CALL ABORT
C$OMP PARALLEL REDUCTION (.OR.:L)
L = .NOT. OMP_IN_PARALLEL ()
C$OMP END PARALLEL
C$OMP PARALLEL REDUCTION (.OR.:L) IF (.TRUE.)
L = .NOT. OMP_IN_PARALLEL ()
C$OMP END PARALLEL
 
E = OMP_GET_WTIME ()
IF (D .GT. E) CALL ABORT
D = OMP_GET_WTICK ()
C Negative precision is definitely wrong,
C bigger than 1s clock resolution is also strange
IF (D .LE. 0 .OR. D .GT. 1.) CALL ABORT
END
/lastprivate2.f90
0,0 → 1,141
program lastprivate
integer :: i, k
common /c/ i, k
!$omp parallel num_threads (4)
call test1
!$omp end parallel
if (i .ne. 21 .or. k .ne. 20) call abort
!$omp parallel num_threads (4)
call test2
!$omp end parallel
if (i .ne. 64 .or. k .ne. 61) call abort
!$omp parallel num_threads (4)
call test3
!$omp end parallel
if (i .ne. 14 .or. k .ne. 11) call abort
call test4
call test5
call test6
call test7
call test8
call test9
call test10
call test11
call test12
contains
subroutine test1
integer :: i, k
common /c/ i, k
!$omp do lastprivate (i, k)
do i = 1, 20
k = i
end do
end subroutine test1
subroutine test2
integer :: i, k
common /c/ i, k
!$omp do lastprivate (i, k)
do i = 7, 61, 3
k = i
end do
end subroutine test2
function ret3 ()
integer :: ret3
ret3 = 3
end function ret3
subroutine test3
integer :: i, k
common /c/ i, k
!$omp do lastprivate (i, k)
do i = -10, 11, ret3 ()
k = i
end do
end subroutine test3
subroutine test4
integer :: j, l
!$omp parallel do lastprivate (j, l) num_threads (4)
do j = 1, 20
l = j
end do
if (j .ne. 21 .or. l .ne. 20) call abort
end subroutine test4
subroutine test5
integer :: j, l
l = 77
!$omp parallel do lastprivate (j, l) num_threads (4) firstprivate (l)
do j = 7, 61, 3
l = j
end do
if (j .ne. 64 .or. l .ne. 61) call abort
end subroutine test5
subroutine test6
integer :: j, l
!$omp parallel do lastprivate (j, l) num_threads (4)
do j = -10, 11, ret3 ()
l = j
end do
if (j .ne. 14 .or. l .ne. 11) call abort
end subroutine test6
subroutine test7
integer :: i, k
common /c/ i, k
!$omp parallel do lastprivate (i, k) num_threads (4)
do i = 1, 20
k = i
end do
if (i .ne. 21 .or. k .ne. 20) call abort
end subroutine test7
subroutine test8
integer :: i, k
common /c/ i, k
!$omp parallel do lastprivate (i, k) num_threads (4)
do i = 7, 61, 3
k = i
end do
if (i .ne. 64 .or. k .ne. 61) call abort
end subroutine test8
subroutine test9
integer :: i, k
common /c/ i, k
k = 77
!$omp parallel do lastprivate (i, k) num_threads (4) firstprivate (k)
do i = -10, 11, ret3 ()
k = i
end do
if (i .ne. 14 .or. k .ne. 11) call abort
end subroutine test9
subroutine test10
integer :: i, k
common /c/ i, k
!$omp parallel num_threads (4)
!$omp do lastprivate (i, k)
do i = 1, 20
k = i
end do
!$omp end parallel
if (i .ne. 21 .or. k .ne. 20) call abort
end subroutine test10
subroutine test11
integer :: i, k
common /c/ i, k
!$omp parallel num_threads (4)
!$omp do lastprivate (i, k)
do i = 7, 61, 3
k = i
end do
!$omp end parallel
if (i .ne. 64 .or. k .ne. 61) call abort
end subroutine test11
subroutine test12
integer :: i, k
common /c/ i, k
k = 77
!$omp parallel num_threads (4)
!$omp do lastprivate (i, k) firstprivate (k)
do i = -10, 11, ret3 ()
k = i
end do
!$omp end parallel
if (i .ne. 14 .or. k .ne. 11) call abort
end subroutine test12
end program lastprivate

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.