2016-08-26  Cesar Philippidis  <cesar@codesourcery.com>

	gcc/fortran/
	* gfortran.h (enum oacc_function): Make OACC_FUNCTION_SEQ the last
	entry the enum.
	(gfc_oacc_routine_name): Add a loc member.
	(gfc_resolve_oacc_routine_call): Declare.
	(gfc_resolve_oacc_routines): Declare.
	* openmp.c (gfc_match_oacc_routine): Make error reporting more
	precise.  Defer rejection of non-function and subroutine symbols
	until gfc_resolve_oacc_routines.
	(struct fortran_omp_context): Add a dims member.
	(gfc_resolve_oacc_blocks): Update ctx->dims.
	(gfc_resolve_oacc_routine_call): New function.
	(gfc_resolve_oacc_routines): New function.
	* resolve.c (resolve_function): Call gfc_resolve_oacc_routine_call.
	(resolve_call): Likewise.
	(resolve_codes): Call gfc_resolve_oacc_routines.

	gcc/testsuite/
	* gfortran.dg/goacc/routine-6.f90: Remove errors deferred to the
	resolving stage.
	* gfortran.dg/goacc/routine-9.f90: New test.
	* gfortran.dg/goacc/routine-nested-parallelism.f: New test.
	* gfortran.dg/goacc/routine-nested-parallelism.f90: New test.


diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 7784e93..192bb1f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -295,10 +295,10 @@ enum save_state
 /* Flags to keep track of ACC routine states.  */
 enum oacc_function
 { OACC_FUNCTION_NONE = 0,
-  OACC_FUNCTION_SEQ,
   OACC_FUNCTION_GANG,
   OACC_FUNCTION_WORKER,
-  OACC_FUNCTION_VECTOR
+  OACC_FUNCTION_VECTOR,
+  OACC_FUNCTION_SEQ
 };
 
 /* Strings for all symbol attributes.  We use these for dumping the
@@ -1631,6 +1631,7 @@ typedef struct gfc_oacc_routine_name
   struct gfc_symbol *sym;
   struct gfc_omp_clauses *clauses;
   struct gfc_oacc_routine_name *next;
+  locus loc;
 }
 gfc_oacc_routine_name;
 
@@ -2994,6 +2995,8 @@ void gfc_resolve_oacc_directive (gfc_code *, gfc_namespace *);
 void gfc_resolve_oacc_declare (gfc_namespace *);
 void gfc_resolve_oacc_parallel_loop_blocks (gfc_code *, gfc_namespace *);
 void gfc_resolve_oacc_blocks (gfc_code *, gfc_namespace *);
+void gfc_resolve_oacc_routine_call (gfc_symbol *, locus *);
+void gfc_resolve_oacc_routines (gfc_namespace *);
 
 /* expr.c */
 void gfc_free_actual_arglist (gfc_actual_arglist *);
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index cb8efb8..cea37ea 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -1951,25 +1951,25 @@ gfc_match_oacc_routine (void)
 	{
 	  if ((isym = gfc_find_function (buffer)) == NULL
 	      && (isym = gfc_find_subroutine (buffer)) == NULL)
-	    st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+	    {
+	      st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+	      if (st == NULL && gfc_current_ns->proc_name->attr.contained
+		  && gfc_current_ns->parent)
+		st = gfc_find_symtree (gfc_current_ns->parent->sym_root,
+				       buffer);
+	    }
 	  if (st)
 	    {
 	      sym = st->n.sym;
 	      if (strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
 	        sym = NULL;
 	    }
-
-	  if ((isym == NULL && st == NULL)
-	      || (sym
-		  && !sym->attr.external
-		  && !sym->attr.function
-		  && !sym->attr.subroutine))
+	  else if (isym == NULL)
 	    {
-	      gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
-			 "invalid function name %s",
-			 (sym) ? sym->name : buffer);
-	      gfc_current_locus = old_loc;
-	      return MATCH_ERROR;
+	      gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, "
+			 "invalid function name %qs", &old_loc, buffer);\
+	      goto cleanup;
+
 	    }
 
 	  /* Set sym to NULL if it matches the current procedure's
@@ -1981,17 +1981,15 @@ gfc_match_oacc_routine (void)
 	}
       else
         {
-	  gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
-	  gfc_current_locus = old_loc;
-	  return MATCH_ERROR;
+	  gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L", &old_loc);
+	  goto cleanup;
 	}
 
       if (gfc_match_char (')') != MATCH_YES)
 	{
-	  gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
-		     " ')' after NAME");
-	  gfc_current_locus = old_loc;
-	  return MATCH_ERROR;
+	  gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, expecting"
+		     " ')' after NAME", &old_loc);
+	  goto cleanup;
 	}
     }
 
@@ -2006,7 +2004,8 @@ gfc_match_oacc_routine (void)
   dims = gfc_oacc_routine_dims (c);
   if (dims == OACC_FUNCTION_NONE)
     {
-      gfc_error ("Multiple loop axes specified in !$ACC ROUTINE at %C");
+      gfc_error ("Multiple loop axes specified in !$ACC ROUTINE at %L",
+		 &old_loc);
 
       /* Don't abort early, because it's important to let the user
 	 know of any potential duplicate routine directives.  */
@@ -2018,8 +2017,8 @@ gfc_match_oacc_routine (void)
       if (c && (c->gang || c->worker || c->vector))
 	{
 	  gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME ) "
-		     "at %C, with incompatible clauses specifying the level "
-		     "of parallelism");
+		     "at %L, with incompatible clauses specifying the level "
+		     "of parallelism", &old_loc);
 	  goto cleanup;
 	}
       /* The intrinsic symbol has been marked with a SEQ, or with no clause at
@@ -2038,7 +2037,7 @@ gfc_match_oacc_routine (void)
 	    needs_entry = false;
 	    if (dims != gfc_oacc_routine_dims (n->clauses))
 	      {
-		gfc_error ("$!ACC ROUTINE already applied at %C");
+		gfc_error ("$!ACC ROUTINE already applied at %L", &old_loc);
 		goto cleanup;
 	      }
 	  }
@@ -2049,6 +2048,7 @@ gfc_match_oacc_routine (void)
 	  n->sym = sym;
 	  n->clauses = c;
 	  n->next = NULL;
+	  n->loc = old_loc;
 
 	  if (gfc_current_ns->oacc_routine_names != NULL)
 	    n->next = gfc_current_ns->oacc_routine_names;
@@ -2064,7 +2064,7 @@ gfc_match_oacc_routine (void)
       if (gfc_current_ns->proc_name->attr.oacc_function != OACC_FUNCTION_NONE
 	  && !seen_error)
 	{
-	  gfc_error ("!$ACC ROUTINE already applied at %C");
+	  gfc_error ("!$ACC ROUTINE already applied at %L", &old_loc);
 	  goto cleanup;
 	}
 
@@ -4559,6 +4559,7 @@ struct fortran_omp_context
   hash_set<gfc_symbol *> *private_iterators;
   struct fortran_omp_context *previous;
   bool is_openmp;
+  oacc_function dims;
 } *omp_current_ctx;
 static gfc_code *omp_current_do_code;
 static int omp_current_do_collapse;
@@ -5198,6 +5199,7 @@ void
 gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
 {
   fortran_omp_context ctx;
+  oacc_function dims = OACC_FUNCTION_NONE;
 
   resolve_oacc_loop_blocks (code);
 
@@ -5206,6 +5208,21 @@ gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
   ctx.private_iterators = new hash_set<gfc_symbol *>;
   ctx.previous = omp_current_ctx;
   ctx.is_openmp = false;
+
+  if (code->ext.omp_clauses->gang)
+    dims = OACC_FUNCTION_GANG;
+  if (code->ext.omp_clauses->worker)
+    dims = OACC_FUNCTION_WORKER;
+  if (code->ext.omp_clauses->vector)
+    dims = OACC_FUNCTION_VECTOR;
+  if (code->ext.omp_clauses->seq)
+    dims = OACC_FUNCTION_SEQ;
+
+  if (dims == OACC_FUNCTION_NONE && ctx.previous != NULL
+      && !ctx.previous->is_openmp)
+    dims = ctx.previous->dims;
+
+  ctx.dims = dims;
   omp_current_ctx = &ctx;
 
   gfc_resolve_blocks (code->block, ns);
@@ -5548,3 +5565,54 @@ gfc_resolve_omp_udrs (gfc_symtree *st)
   for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
     gfc_resolve_omp_udr (omp_udr);
 }
+
+/* Ensure that any calls to OpenACC routines respects the current
+   level of parallelism of the innermost loop.  */
+
+void
+gfc_resolve_oacc_routine_call (gfc_symbol *sym, locus *loc)
+{
+  gfc_oacc_routine_name *n = NULL;
+  oacc_function loop_dims = OACC_FUNCTION_NONE;
+  oacc_function routine_dims;
+
+  if (!omp_current_ctx)
+    return;
+
+  loop_dims = omp_current_ctx->dims;
+
+  if (omp_current_ctx->is_openmp || loop_dims == OACC_FUNCTION_NONE)
+    return;
+
+  for (n = gfc_current_ns->oacc_routine_names; n; n = n->next)
+    if (n->sym == sym)
+      break;
+
+  if (n == NULL)
+    return;
+
+  routine_dims = gfc_oacc_routine_dims (n->clauses);
+
+  if (routine_dims == OACC_FUNCTION_SEQ)
+    return;
+  if (routine_dims <= loop_dims)
+    gfc_error ("Insufficient !$ACC LOOP parallelism available to call "
+	       "%qs at %L", sym->name, loc);
+}
+
+void
+gfc_resolve_oacc_routines (gfc_namespace *ns)
+{
+  gfc_oacc_routine_name *routines = NULL;
+
+  for (routines = ns->oacc_routine_names; routines; routines = routines->next)
+    {
+      gfc_symbol *sym = routines->sym;
+
+      if (!sym->attr.external
+	  && !sym->attr.function
+	  && !sym->attr.subroutine)
+	gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, "
+		   "invalid function name %qs", &routines->loc, sym->name);
+    }
+}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f5cd588..6b67b65 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3131,6 +3131,11 @@ resolve_function (gfc_expr *expr)
     /* typebound procedure: Assume the worst.  */
     gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
 
+  /* Calls to OpenACC routines have imposed restrictions on gang,
+     worker and vector parallelism.  */
+  if (sym)
+    gfc_resolve_oacc_routine_call (sym, &expr->where);
+
   return t;
 }
 
@@ -3474,6 +3479,11 @@ resolve_call (gfc_code *c)
     /* Typebound procedure: Assume the worst.  */
     gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
 
+  /* Calls to OpenACC routines have imposed restrictions on gang,
+     worker and vector parallelism.  */
+  if (csym)
+    gfc_resolve_oacc_routine_call (csym, &c->loc);
+
   return t;
 }
 
@@ -15551,6 +15561,7 @@ resolve_codes (gfc_namespace *ns)
   bitmap_obstack_initialize (&labels_obstack);
 
   gfc_resolve_oacc_declare (ns);
+  gfc_resolve_oacc_routines (ns);
   gfc_resolve_code (ns->code, ns);
 
   bitmap_obstack_release (&labels_obstack);
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-6.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-6.f90
index 10943cf..ee43935 100644
--- a/gcc/testsuite/gfortran.dg/goacc/routine-6.f90
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-6.f90
@@ -5,7 +5,6 @@ contains
   subroutine subr5 (x) 
   implicit none
   !$acc routine (subr5)
-  !$acc routine (m1int) ! { dg-error "invalid function name" }
   integer, intent(inout) :: x
   if (x < 1) then
      x = 1
@@ -26,7 +25,6 @@ program main
   end interface
   integer, parameter :: n = 10
   integer :: a(n), i
-  !$acc routine (subr1) ! { dg-error "invalid function name" }
   external :: subr2
   !$acc routine (subr2)
 
@@ -56,7 +54,6 @@ subroutine subr1 (x)
 end subroutine subr1
 
 subroutine subr2 (x) 
-  !$acc routine (subr1) ! { dg-error "invalid function name" }
   integer, intent(inout) :: x
   if (x < 1) then
      x = 1
@@ -86,7 +83,6 @@ subroutine subr4 (x)
 end subroutine subr4
 
 subroutine subr10 (x)
-  !$acc routine (subr10) device ! { dg-error "Unclassifiable OpenACC directive" }
   integer, intent(inout) :: x
   if (x < 1) then
      x = 1
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-9.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-9.f90
new file mode 100644
index 0000000..590e594
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-9.f90
@@ -0,0 +1,96 @@
+! Check for late resolver errors caused by invalid ACC ROUTINE
+! directives.
+
+module m
+  integer m1int
+contains
+  subroutine subr5 (x)
+    implicit none
+    integer extfunc
+    !$acc routine (subr5)
+    !$acc routine (extfunc)
+    !$acc routine (m1int) ! { dg-error "invalid function name" }
+    integer, intent(inout) :: x
+    if (x < 1) then
+       x = 1
+    else
+       x = x * x - 1 + extfunc(2)
+    end if
+  end subroutine subr5
+end module m
+
+program main
+  implicit none
+  interface
+    function subr6 (x)
+    integer, intent (in) :: x
+    integer :: subr6
+    end function subr6
+  end interface
+  integer, parameter :: n = 10
+  integer :: a(n), i
+  !$acc routine (subr1) ! { dg-error "invalid function name" }
+  external :: subr2
+  !$acc routine (subr2)
+
+  external :: R1, R2
+  !$acc routine (R1)
+  !$acc routine (R2)
+
+  !$acc parallel
+  !$acc loop
+  do i = 1, n
+     call subr1 (i)
+     call subr2 (i)
+  end do
+  !$acc end parallel
+end program main
+
+subroutine subr1 (x)
+  !$acc routine
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+end subroutine subr1
+
+subroutine subr2 (x)
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+end subroutine subr2
+
+subroutine subr3 (x)
+  !$acc routine (subr3)
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     call subr4 (x)
+  end if
+end subroutine subr3
+
+subroutine subr4 (x)
+  !$acc routine (subr4)
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+end subroutine subr4
+
+subroutine subr10 (x)
+  !$acc routine (subr10) device ! { dg-error "Unclassifiable OpenACC directive" }
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+end subroutine subr10
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f
new file mode 100644
index 0000000..d1304c6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f
@@ -0,0 +1,340 @@
+! Validate calls to ACC ROUTINES.  Ensure that the loop containing the
+! call has sufficient parallelism to for the routine.
+
+      subroutine sub
+      implicit none
+      integer, parameter :: n = 100
+      integer :: a(n), i, j
+      external gangr, workerr, vectorr, seqr
+!$acc routine (gangr) gang
+!$acc routine (workerr) worker
+!$acc routine (vectorr) vector
+!$acc routine (seqr) seq
+
+!
+! Test subroutine calls inside nested loops.
+!
+
+!$acc parallel loop
+      do i = 1, n
+         !$acc loop
+         do j = 1, n
+            call workerr (a, n)
+         end do
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop
+      do i = 1, n
+!$acc loop gang
+         do j = 1, n
+            call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+         end do
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to seq routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         call seqr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         call seqr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         call seqr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         call seqr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         call seqr (a, n)
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to gang routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         call gangr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to worker routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         call workerr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         call workerr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to vector routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         call vectorr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         call vectorr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         call vectorr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+      end subroutine sub
+
+      subroutine func
+      implicit none
+      integer, parameter :: n = 100
+      integer :: a(n), i, j
+      integer gangf, workerf, vectorf, seqf
+!$acc routine (gangf) gang
+!$acc routine (workerf) worker
+!$acc routine (vectorf) vector
+!$acc routine (seqf) seq
+
+!
+! Test subroutine calls inside nested loops.
+!
+
+!$acc parallel loop
+      do i = 1, n
+!$acc loop
+         do j = 1, n
+            a(1) = workerf (a, n)
+         end do
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop
+      do i = 1, n
+!$acc loop gang
+         do j = 1, n
+            a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+         end do
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to seq routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         a(1) = seqf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         a(1) = seqf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         a(1) = seqf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         a(1) = seqf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         a(1) = seqf (a, n)
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to gang routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         a(1) = gangf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to worker routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         a(1) = workerf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         a(1) = workerf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to vector routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         a(1) = vectorf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         a(1) = vectorf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         a(1) = vectorf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+      end subroutine func
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f90
new file mode 100644
index 0000000..94e0464
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f90
@@ -0,0 +1,340 @@
+! Validate calls to ACC ROUTINES.  Ensure that the loop containing the
+! call has sufficient parallelism to for the routine.
+
+subroutine sub
+  implicit none
+  integer, parameter :: n = 100
+  integer :: a(n), i, j
+  external gangr, workerr, vectorr, seqr
+  !$acc routine (gangr) gang
+  !$acc routine (workerr) worker
+  !$acc routine (vectorr) vector
+  !$acc routine (seqr) seq
+
+  !
+  ! Test subroutine calls inside nested loops.
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     !$acc loop
+     do j = 1, n
+        call workerr (a, n)
+     end do
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop
+  do i = 1, n
+     !$acc loop gang
+     do j = 1, n
+        call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+     end do
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to seq routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     call seqr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     call seqr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     call seqr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     call seqr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     call seqr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to gang routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     call gangr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to worker routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     call workerr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     call workerr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to vector routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     call vectorr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     call vectorr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     call vectorr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+end subroutine sub
+
+subroutine func
+  implicit none
+  integer, parameter :: n = 100
+  integer :: a(n), i, j
+  integer gangf, workerf, vectorf, seqf
+  !$acc routine (gangf) gang
+  !$acc routine (workerf) worker
+  !$acc routine (vectorf) vector
+  !$acc routine (seqf) seq
+
+  !
+  ! Test subroutine calls inside nested loops.
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     !$acc loop
+     do j = 1, n
+        a(1) = workerf (a, n)
+     end do
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop
+  do i = 1, n
+     !$acc loop gang
+     do j = 1, n
+        a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+     end do
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to seq routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     a(1) = seqf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     a(1) = seqf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     a(1) = seqf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     a(1) = seqf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     a(1) = seqf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to gang routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     a(1) = gangf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to worker routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     a(1) = workerf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     a(1) = workerf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to vector routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     a(1) = vectorf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     a(1) = vectorf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     a(1) = vectorf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+end subroutine func
