From 3d5987f4635e3eaba951180b6caecd4cdf5ad18a Mon Sep 17 00:00:00 2001 From: jakub Date: Sat, 15 Oct 2005 08:55:55 +0000 Subject: [PATCH] fortran/ * openmp.c (gfc_match_omp_variable_list): Add ALLOW_COMMON argument. Disallow COMMON matching if it is set. (gfc_match_omp_clauses, gfc_match_omp_flush): Adjust all callers. (resolve_omp_clauses): Show locus in error messages. Check that variable types in reduction clauses are appropriate for reduction operators. gcc/testsuite/ * gfortran.dg/gomp/reduction1.f90: New test. libgomp/ * testsuite/libgomp.fortran/character2.f90: Remove explicit declaration of omp_get_thread_num. * testsuite/libgomp.fortran/threadprivate1.f90: Likewise. Add use omp_lib. * testsuite/libgomp.fortran/reduction1.f90: New test. * testsuite/libgomp.fortran/reduction2.f90: New test. * testsuite/libgomp.fortran/reduction3.f90: New test. * testsuite/libgomp.fortran/reduction4.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gomp-20050608-branch@105434 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog.gomp | 9 + gcc/fortran/openmp.c | 111 +++++++++---- gcc/testsuite/ChangeLog.gomp | 4 + gcc/testsuite/gfortran.dg/gomp/reduction1.f90 | 130 +++++++++++++++ libgomp/ChangeLog | 12 ++ libgomp/testsuite/libgomp.fortran/character2.f90 | 1 - libgomp/testsuite/libgomp.fortran/reduction1.f90 | 181 +++++++++++++++++++++ libgomp/testsuite/libgomp.fortran/reduction2.f90 | 73 +++++++++ libgomp/testsuite/libgomp.fortran/reduction3.f90 | 103 ++++++++++++ libgomp/testsuite/libgomp.fortran/reduction4.f90 | 56 +++++++ .../testsuite/libgomp.fortran/threadprivate1.f90 | 3 +- 11 files changed, 653 insertions(+), 30 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/gomp/reduction1.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/reduction1.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/reduction2.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/reduction3.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/reduction4.f90 diff --git a/gcc/fortran/ChangeLog.gomp b/gcc/fortran/ChangeLog.gomp index f4fda2207c4..97f93540fb5 100644 --- a/gcc/fortran/ChangeLog.gomp +++ b/gcc/fortran/ChangeLog.gomp @@ -1,3 +1,12 @@ +2005-10-15 Jakub Jelinek + + * openmp.c (gfc_match_omp_variable_list): Add ALLOW_COMMON argument. + Disallow COMMON matching if it is set. + (gfc_match_omp_clauses, gfc_match_omp_flush): Adjust all callers. + (resolve_omp_clauses): Show locus in error messages. Check that + variable types in reduction clauses are appropriate for reduction + operators. + 2005-10-13 Jakub Jelinek * resolve.c (resolve_symbol): Don't error if a threadprivate module diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 61c0add5335..bde088078d0 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -76,7 +76,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) /* Match a variable/common block list and construct a namelist from it. */ static match -gfc_match_omp_variable_list (const char *str, gfc_namelist **list) +gfc_match_omp_variable_list (const char *str, gfc_namelist **list, + bool allow_common) { gfc_namelist *head, *tail, *p; locus old_loc; @@ -115,6 +116,9 @@ gfc_match_omp_variable_list (const char *str, gfc_namelist **list) goto cleanup; } + if (!allow_common) + goto syntax; + m = gfc_match (" / %n /", n); if (m == MATCH_ERROR) goto cleanup; @@ -202,32 +206,35 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask) continue; if ((mask & OMP_CLAUSE_PRIVATE) && gfc_match_omp_variable_list ("private (", - &c->lists[OMP_LIST_PRIVATE]) + &c->lists[OMP_LIST_PRIVATE], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_FIRSTPRIVATE) && gfc_match_omp_variable_list ("firstprivate (", - &c->lists[OMP_LIST_FIRSTPRIVATE]) + &c->lists[OMP_LIST_FIRSTPRIVATE], + true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_LASTPRIVATE) && gfc_match_omp_variable_list ("lastprivate (", - &c->lists[OMP_LIST_LASTPRIVATE]) + &c->lists[OMP_LIST_LASTPRIVATE], + true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_COPYPRIVATE) && gfc_match_omp_variable_list ("copyprivate (", - &c->lists[OMP_LIST_COPYPRIVATE]) + &c->lists[OMP_LIST_COPYPRIVATE], + true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_SHARED) && gfc_match_omp_variable_list ("shared (", - &c->lists[OMP_LIST_SHARED]) + &c->lists[OMP_LIST_SHARED], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_COPYIN) && gfc_match_omp_variable_list ("copyin (", - &c->lists[OMP_LIST_COPYIN]) + &c->lists[OMP_LIST_COPYIN], true) == MATCH_YES) continue; old_loc = gfc_current_locus; @@ -260,7 +267,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask) else if (gfc_match ("ieor") == MATCH_YES) reduction = OMP_LIST_IEOR; if (reduction != OMP_LIST_NUM - && gfc_match_omp_variable_list (" :", &c->lists[reduction]) + && gfc_match_omp_variable_list (" :", &c->lists[reduction], + false) == MATCH_YES) continue; else @@ -378,7 +386,7 @@ match gfc_match_omp_flush (void) { gfc_namelist *list = NULL; - gfc_match_omp_variable_list (" (", &list); + gfc_match_omp_variable_list (" (", &list, true); if (gfc_match_omp_eos () != MATCH_YES) { gfc_free_namelist (list); @@ -693,53 +701,100 @@ resolve_omp_clauses (gfc_code *code) for (; n != NULL; n = n->next) { if (!n->sym->attr.threadprivate) - gfc_error ("Non-THREADPRIVATE object %s in COPYIN clause", - n->sym->name); + gfc_error ("Non-THREADPRIVATE object %s in COPYIN clause" + " at %L", n->sym->name, &code->loc); if (n->sym->attr.allocatable) - gfc_error ("COPYIN clause object %s is ALLOCATABLE", - n->sym->name); + gfc_error ("COPYIN clause object %s is ALLOCATABLE at %L", + n->sym->name, &code->loc); } break; case OMP_LIST_COPYPRIVATE: for (; n != NULL; n = n->next) { if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) - gfc_error ("Assumed size array %s in COPYPRIVATE clause", - n->sym->name); + gfc_error ("Assumed size array %s in COPYPRIVATE clause" + " at %L", n->sym->name, &code->loc); if (n->sym->attr.allocatable) - gfc_error ("COPYPRIVATE clause object %s is ALLOCATABLE", - n->sym->name); + gfc_error ("COPYPRIVATE clause object %s is ALLOCATABLE" + " at %L", n->sym->name, &code->loc); } break; case OMP_LIST_SHARED: for (; n != NULL; n = n->next) if (n->sym->attr.threadprivate) - gfc_error ("THREADPRIVATE object %s in SHARED clause", - n->sym->name); + gfc_error ("THREADPRIVATE object %s in SHARED clause at %L", + n->sym->name, &code->loc); break; default: for (; n != NULL; n = n->next) { if (n->sym->attr.threadprivate) - gfc_error ("THREADPRIVATE object %s in %s clause", - n->sym->name, name); + gfc_error ("THREADPRIVATE object %s in %s clause at %L", + n->sym->name, name, &code->loc); if (list != OMP_LIST_PRIVATE) { if (n->sym->attr.pointer) - gfc_error ("POINTER object %s in %s clause", - n->sym->name, name); + gfc_error ("POINTER object %s in %s clause at %L", + n->sym->name, name, &code->loc); if (n->sym->attr.allocatable) - gfc_error ("%s clause object %s is ALLOCATABLE", - name, n->sym->name); + gfc_error ("%s clause object %s is ALLOCATABLE at %L", + name, n->sym->name, &code->loc); } if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) - gfc_error ("Assumed size array %s in %s clause", - n->sym->name, name); + gfc_error ("Assumed size array %s in %s clause at %L", + n->sym->name, name, &code->loc); if (n->sym->attr.in_namelist && (list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST)) gfc_error ("Variable %s in %s clause is used in" - " NAMELIST statement", n->sym->name, name); + " NAMELIST statement at %L", + n->sym->name, name, &code->loc); + switch (list) + { + case OMP_LIST_PLUS: + case OMP_LIST_MULT: + case OMP_LIST_SUB: + if (!gfc_numeric_ts (&n->sym->ts)) + gfc_error ("%c REDUCTION variable %s is %s at %L", + list == OMP_LIST_PLUS ? '+' + : list == OMP_LIST_MULT ? '*' : '-', + n->sym->name, gfc_typename (&n->sym->ts), + &code->loc); + break; + case OMP_LIST_AND: + case OMP_LIST_OR: + case OMP_LIST_EQV: + case OMP_LIST_NEQV: + if (n->sym->ts.type != BT_LOGICAL) + gfc_error ("%s REDUCTION variable %s must be LOGICAL" + " at %L", + list == OMP_LIST_AND ? ".AND." + : list == OMP_LIST_OR ? ".OR." + : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.", + n->sym->name, &code->loc); + break; + case OMP_LIST_MAX: + case OMP_LIST_MIN: + if (n->sym->ts.type != BT_INTEGER + && n->sym->ts.type != BT_REAL) + gfc_error ("%s REDUCTION variable %s must be" + " INTEGER or REAL at %L", + list == OMP_LIST_MAX ? "MAX" : "MIN", + n->sym->name, &code->loc); + break; + case OMP_LIST_IAND: + case OMP_LIST_IOR: + case OMP_LIST_IEOR: + if (n->sym->ts.type != BT_INTEGER) + gfc_error ("%s REDUCTION variable %s must be INTEGER" + " at %L", + list == OMP_LIST_IAND ? "IAND" + : list == OMP_LIST_MULT ? "IOR" : "IEOR", + n->sym->name, &code->loc); + break; + default: + break; + } } break; } diff --git a/gcc/testsuite/ChangeLog.gomp b/gcc/testsuite/ChangeLog.gomp index 2dbfca1e691..f1e0250548e 100644 --- a/gcc/testsuite/ChangeLog.gomp +++ b/gcc/testsuite/ChangeLog.gomp @@ -1,3 +1,7 @@ +2005-10-15 Jakub Jelinek + + * gfortran.dg/gomp/reduction1.f90: New test. + 2005-10-13 Jakub Jelinek * gfortran.dg/gomp/omp_threadprivate2.f90: New test. diff --git a/gcc/testsuite/gfortran.dg/gomp/reduction1.f90 b/gcc/testsuite/gfortran.dg/gomp/reduction1.f90 new file mode 100644 index 00000000000..b6d7695c012 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/reduction1.f90 @@ -0,0 +1,130 @@ +! { dg-do compile } + +subroutine foo (ia1) +integer :: i1, i2, i3 +integer, dimension (*) :: ia1 +integer, dimension (10) :: ia2 +real :: r1 +real, dimension (5) :: ra1 +double precision :: d1 +double precision, dimension (4) :: da1 +complex :: c1 +complex, dimension (7) :: ca1 +logical :: l1 +logical, dimension (3) :: la1 +character (5) :: a1 +type t + integer :: i +end type +type(t) :: t1 +type(t), dimension (2) :: ta1 +real, pointer :: p1 => NULL() +integer, allocatable :: aa1 (:,:) +save i2 +!$omp threadprivate (i2) +common /blk/ i1 + +!$omp parallel reduction (+:i3, ia2, r1, ra1, d1, da1, c1, ca1) +!$omp end parallel +!$omp parallel reduction (*:i3, ia2, r1, ra1, d1, da1, c1, ca1) +!$omp end parallel +!$omp parallel reduction (-:i3, ia2, r1, ra1, d1, da1, c1, ca1) +!$omp end parallel +!$omp parallel reduction (.and.:l1, la1) +!$omp end parallel +!$omp parallel reduction (.or.:l1, la1) +!$omp end parallel +!$omp parallel reduction (.eqv.:l1, la1) +!$omp end parallel +!$omp parallel reduction (.neqv.:l1, la1) +!$omp end parallel +!$omp parallel reduction (min:i3, ia2, r1, ra1, d1, da1) +!$omp end parallel +!$omp parallel reduction (max:i3, ia2, r1, ra1, d1, da1) +!$omp end parallel +!$omp parallel reduction (iand:i3, ia2) +!$omp end parallel +!$omp parallel reduction (ior:i3, ia2) +!$omp end parallel +!$omp parallel reduction (ieor:i3, ia2) +!$omp end parallel +!$omp parallel reduction (+:/blk/) ! { dg-error "Syntax error" } +!$omp end parallel ! { dg-error "Unexpected" } +!$omp parallel reduction (+:i2) ! { dg-error "THREADPRIVATE object" } +!$omp end parallel +!$omp parallel reduction (*:p1) ! { dg-error "POINTER object" } +!$omp end parallel +!$omp parallel reduction (-:aa1) ! { dg-error "is ALLOCATABLE" } +!$omp end parallel +!$omp parallel reduction (*:ia1) ! { dg-error "Assumed size" } +!$omp end parallel +!$omp parallel reduction (+:l1) ! { dg-error "is LOGICAL" } +!$omp end parallel +!$omp parallel reduction (*:la1) ! { dg-error "is LOGICAL" } +!$omp end parallel +!$omp parallel reduction (-:a1) ! { dg-error "is CHARACTER" } +!$omp end parallel +!$omp parallel reduction (+:t1) ! { dg-error "is TYPE" } +!$omp end parallel +!$omp parallel reduction (*:ta1) ! { dg-error "is TYPE" } +!$omp end parallel +!$omp parallel reduction (.and.:i3) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.or.:ia2) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.eqv.:r1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.neqv.:ra1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.and.:d1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.or.:da1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.eqv.:c1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.neqv.:ca1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.and.:a1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.or.:t1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.eqv.:ta1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (min:c1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (max:ca1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (max:l1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (min:la1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (max:a1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (min:t1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (max:ta1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (iand:r1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ior:ra1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ieor:d1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ior:da1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (iand:c1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ior:ca1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ieor:l1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (iand:la1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ior:a1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ieor:t1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (iand:ta1) ! { dg-error "must be INTEGER" } +!$omp end parallel + +end subroutine diff --git a/libgomp/ChangeLog b/libgomp/ChangeLog index e32ee1ae12e..398f515e80c 100644 --- a/libgomp/ChangeLog +++ b/libgomp/ChangeLog @@ -1,3 +1,15 @@ +2005-10-15 Jakub Jelinek + + * testsuite/libgomp.fortran/character2.f90: Remove explicit + declaration of omp_get_thread_num. + * testsuite/libgomp.fortran/threadprivate1.f90: Likewise. Add + use omp_lib. + + * testsuite/libgomp.fortran/reduction1.f90: New test. + * testsuite/libgomp.fortran/reduction2.f90: New test. + * testsuite/libgomp.fortran/reduction3.f90: New test. + * testsuite/libgomp.fortran/reduction4.f90: New test. + 2005-10-13 Richard Henderson * Makefile.am (libgomp_la_SOURCES): Add bar.c. diff --git a/libgomp/testsuite/libgomp.fortran/character2.f90 b/libgomp/testsuite/libgomp.fortran/character2.f90 index 74c2ed36c40..b26aeabda4e 100644 --- a/libgomp/testsuite/libgomp.fortran/character2.f90 +++ b/libgomp/testsuite/libgomp.fortran/character2.f90 @@ -14,7 +14,6 @@ contains character (len = n) :: t character (len = n) :: u integer, dimension (n + 4) :: s - integer omp_get_thread_num logical :: l integer :: m r = '' diff --git a/libgomp/testsuite/libgomp.fortran/reduction1.f90 b/libgomp/testsuite/libgomp.fortran/reduction1.f90 new file mode 100644 index 00000000000..14da80b525a --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/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 diff --git a/libgomp/testsuite/libgomp.fortran/reduction2.f90 b/libgomp/testsuite/libgomp.fortran/reduction2.f90 new file mode 100644 index 00000000000..9bdeb77de85 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/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 diff --git a/libgomp/testsuite/libgomp.fortran/reduction3.f90 b/libgomp/testsuite/libgomp.fortran/reduction3.f90 new file mode 100644 index 00000000000..a0786eca008 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/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. -2147483648 .or. any (ia .ne. -2147483648)) 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 diff --git a/libgomp/testsuite/libgomp.fortran/reduction4.f90 b/libgomp/testsuite/libgomp.fortran/reduction4.f90 new file mode 100644 index 00000000000..5a5e852bea7 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/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 = Z'ffffffff' + +!$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 diff --git a/libgomp/testsuite/libgomp.fortran/threadprivate1.f90 b/libgomp/testsuite/libgomp.fortran/threadprivate1.f90 index ace96e0c15e..a8e2b633ad9 100644 --- a/libgomp/testsuite/libgomp.fortran/threadprivate1.f90 +++ b/libgomp/testsuite/libgomp.fortran/threadprivate1.f90 @@ -1,11 +1,12 @@ ! { dg-do run } + module threadprivate1 double precision :: d !$omp threadprivate (d) end module threadprivate1 +!$ use omp_lib use threadprivate1 - integer omp_get_thread_num logical :: l l = .false. !$omp parallel num_threads (4) reduction (.or.:l) -- 2.11.4.GIT