diff mbox

[Fortran] PR44646 - Add parser support for DO CONCURRENT

Message ID 4E62226E.7080502@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Sept. 3, 2011, 12:49 p.m. UTC
Recently, I came across PR 44646, where I wrote a bit more than a year 
ago: "I have an embryonic patch for it". Well, I found it again, did 
some polishing - and here it is.

This patch implements the parsing/diagnostic for "DO[,] CONCURRENT 
for-all-header", e.g.
   do concurrent (i = 1:5)
     A(i) = B(i)
   end do

DO CONCURRENT allows the compiler to go through the loop in any order 
and also in parallel; some constraints help to avoid dependencies, but 
it is the duty of the programmer to ensure that the order does not 
matter. That's one difference to the FORALL construct; another is that 
one is allow to do much more in the DO CONCURRENT block than FORALL 
allows: Other loops, conditional jumps, ...

TODO as follow up:
- Replace "Sorry" by a real implementation in trans-stmt.c
- Add documentation to gfc-internal.texi, update gfortran.texi (F2003 
status) and the wiki
- Try to make use of the constraints for the middle end (optimization, 
autoparallelization), if possible.
- Optionally (-fdo-concurrent=...?), parallelize the loop (e.g. by 
adding OpenMP pragmas).

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias
diff mbox

Patch

2011-09-03  Tobias Burnus  <burnus@net-b.de>

	PR fortran/44646
	* decl.c (gfc_match_entry, gfc_match_end): Handle COMP_DO_CONCURRENT.
	* dump-parse-tree.c (show_code_node): Handle EXEC_DO_CONCURRENT.
	* gfortran.h (gfc_exec_op): Add EXEC_DO_CONCURRENT.
	* match.c (gfc_match_critical, match_exit_cycle, gfc_match_stopcode,
	lock_unlock_statement, sync_statement, gfc_match_allocate,
	gfc_match_deallocate, gfc_match_return): Add DO CONCURRENT diagnostic.
	(gfc_match_do): Match DO CONCURRENT.
	(match_derived_type_spec, match_type_spec, gfc_free_forall_iterator,
	match_forall_iterator, match_forall_header, match_simple_forall,
	gfc_match_forall): Move up in the file.
	* parse.c (check_do_closure, parse_do_block): Handle do concurrent.
	* parse.h (gfc_compile_state): Add COMP_DO_CONCURRENT.
	* resolve.c (do_concurrent_flag): New global variable.
	(resolve_function, pure_subroutine, resolve_branch,
	gfc_resolve_blocks, resolve_code, resolve_types): Add do concurrent
	diagnostic.
	* st.c (gfc_free_statement): Handle EXEC_DO_CONCURRENT.
	* trans-stmt.c (gfc_trans_do_concurrent): New function.
	* trans-stmt.h (gfc_trans_do_concurrent): Ditto.
	* trans.c (trans_code): Call it.

2011-09-03  Tobias Burnus  <burnus@net-b.de>

	PR fortran/44646
	* gfortran.dg/do_concurrent_1.f90: New.

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 18e2651..0ee2575 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -5248,6 +5248,7 @@  gfc_match_entry (void)
 		       "an IF-THEN block");
 	    break;
 	  case COMP_DO:
+	  case COMP_DO_CONCURRENT:
 	    gfc_error ("ENTRY statement at %C cannot appear within "
 		       "a DO block");
 	    break;
@@ -5853,6 +5854,7 @@  gfc_match_end (gfc_statement *st)
       break;
 
     case COMP_DO:
+    case COMP_DO_CONCURRENT:
       *st = ST_ENDDO;
       target = " do";
       eos_ok = 0;
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index ad8b554..af2cd85 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1611,6 +1611,28 @@  show_code_node (int level, gfc_code *c)
       fputs ("END DO", dumpfile);
       break;
 
+    case EXEC_DO_CONCURRENT:
+      fputs ("DO CONCURRENT ", dumpfile);
+      for (fa = c->ext.forall_iterator; fa; fa = fa->next)
+        {
+          show_expr (fa->var);
+          fputc (' ', dumpfile);
+          show_expr (fa->start);
+          fputc (':', dumpfile);
+          show_expr (fa->end);
+          fputc (':', dumpfile);
+          show_expr (fa->stride);
+
+          if (fa->next != NULL)
+            fputc (',', dumpfile);
+        }
+      show_expr (c->expr1);
+
+      show_code (level + 1, c->block->next);
+      code_indent (level, c->label1);
+      fputs ("END DO", dumpfile);
+      break;
+
     case EXEC_DO_WHILE:
       fputs ("DO WHILE ", dumpfile);
       show_expr (c->expr1);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ac36d24..54e0b20 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2052,10 +2052,10 @@  typedef enum
   EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_CRITICAL, EXEC_ERROR_STOP,
   EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
   EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
-  EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK,
-  EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC,
-  EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE, EXEC_SELECT_TYPE,
-  EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES,
+  EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_CONCURRENT, EXEC_DO_WHILE,
+  EXEC_SELECT, EXEC_BLOCK, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
+  EXEC_CALL_PPC, EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE,
+  EXEC_SELECT_TYPE, EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES,
   EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
   EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
   EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 43aeb19..63410f8 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1748,6 +1748,13 @@  gfc_match_critical (void)
       return MATCH_ERROR;
     }
 
+  if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
+    {
+      gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
+		 "block");
+      return MATCH_ERROR;
+    }
+
   if (gfc_implicit_pure (NULL))
     gfc_current_ns->proc_name->attr.implicit_pure = 0;
 
@@ -1893,6 +1900,436 @@  error:
 }
 
 
+/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
+   an accessible derived type.  */
+
+static match
+match_derived_type_spec (gfc_typespec *ts)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  locus old_locus; 
+  gfc_symbol *derived;
+
+  old_locus = gfc_current_locus;
+
+  if (gfc_match ("%n", name) != MATCH_YES)
+    {
+       gfc_current_locus = old_locus;
+       return MATCH_NO;
+    }
+
+  gfc_find_symbol (name, NULL, 1, &derived);
+
+  if (derived && derived->attr.flavor == FL_DERIVED)
+    {
+      ts->type = BT_DERIVED;
+      ts->u.derived = derived;
+      return MATCH_YES;
+    }
+
+  gfc_current_locus = old_locus; 
+  return MATCH_NO;
+}
+
+
+/* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
+   gfc_match_decl_type_spec() from decl.c, with the following exceptions:
+   It only includes the intrinsic types from the Fortran 2003 standard
+   (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
+   the implicit_flag is not needed, so it was removed. Derived types are
+   identified by their name alone.  */
+
+static match
+match_type_spec (gfc_typespec *ts)
+{
+  match m;
+  locus old_locus;
+
+  gfc_clear_ts (ts);
+  gfc_gobble_whitespace ();
+  old_locus = gfc_current_locus;
+
+  if (match_derived_type_spec (ts) == MATCH_YES)
+    {
+      /* Enforce F03:C401.  */
+      if (ts->u.derived->attr.abstract)
+	{
+	  gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
+		     ts->u.derived->name, &old_locus);
+	  return MATCH_ERROR;
+	}
+      return MATCH_YES;
+    }
+
+  if (gfc_match ("integer") == MATCH_YES)
+    {
+      ts->type = BT_INTEGER;
+      ts->kind = gfc_default_integer_kind;
+      goto kind_selector;
+    }
+
+  if (gfc_match ("real") == MATCH_YES)
+    {
+      ts->type = BT_REAL;
+      ts->kind = gfc_default_real_kind;
+      goto kind_selector;
+    }
+
+  if (gfc_match ("double precision") == MATCH_YES)
+    {
+      ts->type = BT_REAL;
+      ts->kind = gfc_default_double_kind;
+      return MATCH_YES;
+    }
+
+  if (gfc_match ("complex") == MATCH_YES)
+    {
+      ts->type = BT_COMPLEX;
+      ts->kind = gfc_default_complex_kind;
+      goto kind_selector;
+    }
+
+  if (gfc_match ("character") == MATCH_YES)
+    {
+      ts->type = BT_CHARACTER;
+
+      m = gfc_match_char_spec (ts);
+
+      if (m == MATCH_NO)
+	m = MATCH_YES;
+
+      return m;
+    }
+
+  if (gfc_match ("logical") == MATCH_YES)
+    {
+      ts->type = BT_LOGICAL;
+      ts->kind = gfc_default_logical_kind;
+      goto kind_selector;
+    }
+
+  /* If a type is not matched, simply return MATCH_NO.  */
+  gfc_current_locus = old_locus;
+  return MATCH_NO;
+
+kind_selector:
+
+  gfc_gobble_whitespace ();
+  if (gfc_peek_ascii_char () == '*')
+    {
+      gfc_error ("Invalid type-spec at %C");
+      return MATCH_ERROR;
+    }
+
+  m = gfc_match_kind_spec (ts, false);
+
+  if (m == MATCH_NO)
+    m = MATCH_YES;		/* No kind specifier found.  */
+
+  return m;
+}
+
+
+/******************** FORALL subroutines ********************/
+
+/* Free a list of FORALL iterators.  */
+
+void
+gfc_free_forall_iterator (gfc_forall_iterator *iter)
+{
+  gfc_forall_iterator *next;
+
+  while (iter)
+    {
+      next = iter->next;
+      gfc_free_expr (iter->var);
+      gfc_free_expr (iter->start);
+      gfc_free_expr (iter->end);
+      gfc_free_expr (iter->stride);
+      free (iter);
+      iter = next;
+    }
+}
+
+
+/* Match an iterator as part of a FORALL statement.  The format is:
+
+     <var> = <start>:<end>[:<stride>]
+
+   On MATCH_NO, the caller tests for the possibility that there is a
+   scalar mask expression.  */
+
+static match
+match_forall_iterator (gfc_forall_iterator **result)
+{
+  gfc_forall_iterator *iter;
+  locus where;
+  match m;
+
+  where = gfc_current_locus;
+  iter = XCNEW (gfc_forall_iterator);
+
+  m = gfc_match_expr (&iter->var);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (gfc_match_char ('=') != MATCH_YES
+      || iter->var->expr_type != EXPR_VARIABLE)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  m = gfc_match_expr (&iter->start);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (gfc_match_char (':') != MATCH_YES)
+    goto syntax;
+
+  m = gfc_match_expr (&iter->end);
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  if (gfc_match_char (':') == MATCH_NO)
+    iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+  else
+    {
+      m = gfc_match_expr (&iter->stride);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+    }
+
+  /* Mark the iteration variable's symbol as used as a FORALL index.  */
+  iter->var->symtree->n.sym->forall_index = true;
+
+  *result = iter;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in FORALL iterator at %C");
+  m = MATCH_ERROR;
+
+cleanup:
+
+  gfc_current_locus = where;
+  gfc_free_forall_iterator (iter);
+  return m;
+}
+
+
+/* Match the header of a FORALL statement.  */
+
+static match
+match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
+{
+  gfc_forall_iterator *head, *tail, *new_iter;
+  gfc_expr *msk;
+  match m;
+
+  gfc_gobble_whitespace ();
+
+  head = tail = NULL;
+  msk = NULL;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    return MATCH_NO;
+
+  m = match_forall_iterator (&new_iter);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    goto syntax;
+
+  head = tail = new_iter;
+
+  for (;;)
+    {
+      if (gfc_match_char (',') != MATCH_YES)
+	break;
+
+      m = match_forall_iterator (&new_iter);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      if (m == MATCH_YES)
+	{
+	  tail->next = new_iter;
+	  tail = new_iter;
+	  continue;
+	}
+
+      /* Have to have a mask expression.  */
+
+      m = gfc_match_expr (&msk);
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      break;
+    }
+
+  if (gfc_match_char (')') == MATCH_NO)
+    goto syntax;
+
+  *phead = head;
+  *mask = msk;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_FORALL);
+
+cleanup:
+  gfc_free_expr (msk);
+  gfc_free_forall_iterator (head);
+
+  return MATCH_ERROR;
+}
+
+/* Match the rest of a simple FORALL statement that follows an 
+   IF statement.  */
+
+static match
+match_simple_forall (void)
+{
+  gfc_forall_iterator *head;
+  gfc_expr *mask;
+  gfc_code *c;
+  match m;
+
+  mask = NULL;
+  head = NULL;
+  c = NULL;
+
+  m = match_forall_header (&head, &mask);
+
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  m = gfc_match_assignment ();
+
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_pointer_assignment ();
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  c = gfc_get_code ();
+  *c = new_st;
+  c->loc = gfc_current_locus;
+
+  if (gfc_match_eos () != MATCH_YES)
+    goto syntax;
+
+  gfc_clear_new_st ();
+  new_st.op = EXEC_FORALL;
+  new_st.expr1 = mask;
+  new_st.ext.forall_iterator = head;
+  new_st.block = gfc_get_code ();
+
+  new_st.block->op = EXEC_FORALL;
+  new_st.block->next = c;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_FORALL);
+
+cleanup:
+  gfc_free_forall_iterator (head);
+  gfc_free_expr (mask);
+
+  return MATCH_ERROR;
+}
+
+
+/* Match a FORALL statement.  */
+
+match
+gfc_match_forall (gfc_statement *st)
+{
+  gfc_forall_iterator *head;
+  gfc_expr *mask;
+  gfc_code *c;
+  match m0, m;
+
+  head = NULL;
+  mask = NULL;
+  c = NULL;
+
+  m0 = gfc_match_label ();
+  if (m0 == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  m = gfc_match (" forall");
+  if (m != MATCH_YES)
+    return m;
+
+  m = match_forall_header (&head, &mask);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    goto syntax;
+
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      *st = ST_FORALL_BLOCK;
+      new_st.op = EXEC_FORALL;
+      new_st.expr1 = mask;
+      new_st.ext.forall_iterator = head;
+      return MATCH_YES;
+    }
+
+  m = gfc_match_assignment ();
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_pointer_assignment ();
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  c = gfc_get_code ();
+  *c = new_st;
+  c->loc = gfc_current_locus;
+
+  gfc_clear_new_st ();
+  new_st.op = EXEC_FORALL;
+  new_st.expr1 = mask;
+  new_st.ext.forall_iterator = head;
+  new_st.block = gfc_get_code ();
+  new_st.block->op = EXEC_FORALL;
+  new_st.block->next = c;
+
+  *st = ST_FORALL;
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_FORALL);
+
+cleanup:
+  gfc_free_forall_iterator (head);
+  gfc_free_expr (mask);
+  gfc_free_statements (c);
+  return MATCH_NO;
+}
+
+
 /* Match a DO statement.  */
 
 match
@@ -1937,6 +2374,46 @@  gfc_match_do (void)
   if (gfc_match_parens () == MATCH_ERROR)
     return MATCH_ERROR;
 
+  if (gfc_match (" concurrent") == MATCH_YES)
+    {
+      gfc_forall_iterator *head;
+      gfc_expr *mask;
+
+      if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: DO CONCURRENT "
+			   "construct at %C") == FAILURE)
+	return MATCH_ERROR;
+
+
+      mask = NULL;
+      head = NULL;
+      m = match_forall_header (&head, &mask);
+
+      if (m == MATCH_NO)
+	return m;
+      if (m == MATCH_ERROR)
+	goto concurr_cleanup;
+
+      if (gfc_match_eos () != MATCH_YES)
+	goto concurr_cleanup;
+
+      if (label != NULL
+	   && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
+	goto concurr_cleanup;
+
+      new_st.label1 = label;
+      new_st.op = EXEC_DO_CONCURRENT;
+      new_st.expr1 = mask;
+      new_st.ext.forall_iterator = head;
+
+      return MATCH_YES;
+
+concurr_cleanup:
+      gfc_syntax_error (ST_DO);
+      gfc_free_expr (mask);
+      gfc_free_forall_iterator (head);
+      return MATCH_ERROR;
+    }
+
   /* See if we have a DO WHILE.  */
   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
     {
@@ -2052,6 +2529,14 @@  match_exit_cycle (gfc_statement st, gfc_exec_op op)
 		  gfc_ascii_statement (st));
 	return MATCH_ERROR;
       }
+    else if (p->state == COMP_DO_CONCURRENT
+	     && (op == EXEC_EXIT || (sym && sym != p->sym)))
+      {
+	/* F2008, C821 & C845.  */
+	gfc_error("%s statement at %C leaves DO CONCURRENT construct",
+		  gfc_ascii_statement (st));
+	return MATCH_ERROR;
+      }
     else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO))
       break;
 
@@ -2071,6 +2556,7 @@  match_exit_cycle (gfc_statement st, gfc_exec_op op)
   switch (p->state)
     {
     case COMP_DO:
+    case COMP_DO_CONCURRENT:
       break;
 
     case COMP_CRITICAL:
@@ -2202,6 +2688,11 @@  gfc_match_stopcode (gfc_statement st)
       gfc_error ("Image control statement STOP at %C in CRITICAL block");
       goto cleanup;
     }
+  if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
+    {
+      gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
+      goto cleanup;
+    }
 
   if (e != NULL)
     {
@@ -2325,7 +2816,8 @@  lock_unlock_statement (gfc_statement st)
 
   if (gfc_pure (NULL))
     {
-      gfc_error ("Image control statement SYNC at %C in PURE procedure");
+      gfc_error ("Image control statement %s at %C in PURE procedure",
+		 st == ST_LOCK ? "LOCK" : "UNLOCK");
       return MATCH_ERROR;
     }
 
@@ -2340,7 +2832,15 @@  lock_unlock_statement (gfc_statement st)
 
   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
     {
-      gfc_error ("Image control statement SYNC at %C in CRITICAL block");
+      gfc_error ("Image control statement %s at %C in CRITICAL block",
+		 st == ST_LOCK ? "LOCK" : "UNLOCK");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
+    {
+      gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
+		 st == ST_LOCK ? "LOCK" : "UNLOCK");
       return MATCH_ERROR;
     }
 
@@ -2532,6 +3032,12 @@  sync_statement (gfc_statement st)
       return MATCH_ERROR;
     }
 
+  if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
+    {
+      gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
+      return MATCH_ERROR;
+    }
+
   if (gfc_match_eos () == MATCH_YES)
     {
       if (st == ST_SYNC_IMAGES)
@@ -2905,136 +3411,6 @@  gfc_free_alloc_list (gfc_alloc *p)
 }
 
 
-/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
-   an accessible derived type.  */
-
-static match
-match_derived_type_spec (gfc_typespec *ts)
-{
-  char name[GFC_MAX_SYMBOL_LEN + 1];
-  locus old_locus; 
-  gfc_symbol *derived;
-
-  old_locus = gfc_current_locus;
-
-  if (gfc_match ("%n", name) != MATCH_YES)
-    {
-       gfc_current_locus = old_locus;
-       return MATCH_NO;
-    }
-
-  gfc_find_symbol (name, NULL, 1, &derived);
-
-  if (derived && derived->attr.flavor == FL_DERIVED)
-    {
-      ts->type = BT_DERIVED;
-      ts->u.derived = derived;
-      return MATCH_YES;
-    }
-
-  gfc_current_locus = old_locus; 
-  return MATCH_NO;
-}
-
-
-/* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
-   gfc_match_decl_type_spec() from decl.c, with the following exceptions:
-   It only includes the intrinsic types from the Fortran 2003 standard
-   (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
-   the implicit_flag is not needed, so it was removed. Derived types are
-   identified by their name alone.  */
-
-static match
-match_type_spec (gfc_typespec *ts)
-{
-  match m;
-  locus old_locus;
-
-  gfc_clear_ts (ts);
-  gfc_gobble_whitespace ();
-  old_locus = gfc_current_locus;
-
-  if (match_derived_type_spec (ts) == MATCH_YES)
-    {
-      /* Enforce F03:C401.  */
-      if (ts->u.derived->attr.abstract)
-	{
-	  gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
-		     ts->u.derived->name, &old_locus);
-	  return MATCH_ERROR;
-	}
-      return MATCH_YES;
-    }
-
-  if (gfc_match ("integer") == MATCH_YES)
-    {
-      ts->type = BT_INTEGER;
-      ts->kind = gfc_default_integer_kind;
-      goto kind_selector;
-    }
-
-  if (gfc_match ("real") == MATCH_YES)
-    {
-      ts->type = BT_REAL;
-      ts->kind = gfc_default_real_kind;
-      goto kind_selector;
-    }
-
-  if (gfc_match ("double precision") == MATCH_YES)
-    {
-      ts->type = BT_REAL;
-      ts->kind = gfc_default_double_kind;
-      return MATCH_YES;
-    }
-
-  if (gfc_match ("complex") == MATCH_YES)
-    {
-      ts->type = BT_COMPLEX;
-      ts->kind = gfc_default_complex_kind;
-      goto kind_selector;
-    }
-
-  if (gfc_match ("character") == MATCH_YES)
-    {
-      ts->type = BT_CHARACTER;
-
-      m = gfc_match_char_spec (ts);
-
-      if (m == MATCH_NO)
-	m = MATCH_YES;
-
-      return m;
-    }
-
-  if (gfc_match ("logical") == MATCH_YES)
-    {
-      ts->type = BT_LOGICAL;
-      ts->kind = gfc_default_logical_kind;
-      goto kind_selector;
-    }
-
-  /* If a type is not matched, simply return MATCH_NO.  */
-  gfc_current_locus = old_locus;
-  return MATCH_NO;
-
-kind_selector:
-
-  gfc_gobble_whitespace ();
-  if (gfc_peek_ascii_char () == '*')
-    {
-      gfc_error ("Invalid type-spec at %C");
-      return MATCH_ERROR;
-    }
-
-  m = gfc_match_kind_spec (ts, false);
-
-  if (m == MATCH_NO)
-    m = MATCH_YES;		/* No kind specifier found.  */
-
-  return m;
-}
-
-
 /* Match an ALLOCATE statement.  */
 
 match
@@ -3129,6 +3505,27 @@  gfc_match_allocate (void)
 	  deferred_locus = tail->expr->where;
 	}
 
+      if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS
+	  || gfc_find_state (COMP_CRITICAL) == SUCCESS)
+	{
+	  gfc_ref *ref;
+	  bool coarray = tail->expr->symtree->n.sym->attr.codimension;
+	  for (ref = tail->expr->ref; ref; ref = ref->next)
+	    if (ref->type == REF_COMPONENT)
+	      coarray = ref->u.c.component->attr.codimension;
+
+	  if (coarray && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
+	    {
+	      gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
+	      goto cleanup;
+	    }
+	  if (coarray && gfc_find_state (COMP_CRITICAL) == SUCCESS)
+	    {
+	      gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
+	      goto cleanup;
+	    }
+	}
+
       /* The ALLOCATE statement had an optional typespec.  Check the
 	 constraints.  */
       if (ts.type != BT_UNKNOWN)
@@ -3477,6 +3874,20 @@  gfc_match_deallocate (void)
       if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
 	gfc_current_ns->proc_name->attr.implicit_pure = 0;
 
+      if (gfc_is_coarray (tail->expr)
+	  && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
+	{
+	  gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
+	  goto cleanup;
+	}
+
+      if (gfc_is_coarray (tail->expr)
+	  && gfc_find_state (COMP_CRITICAL) == SUCCESS)
+	{
+	  gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
+	  goto cleanup;
+	}
+
       /* FIXME: disable the checking on derived types.  */
       b1 = !(tail->expr->ref
 	   && (tail->expr->ref->type == REF_COMPONENT
@@ -3588,6 +3999,12 @@  gfc_match_return (void)
       return MATCH_ERROR;
     }
 
+  if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
+    {
+      gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
+      return MATCH_ERROR;
+    }
+
   if (gfc_match_eos () == MATCH_YES)
     goto done;
 
@@ -5188,303 +5605,3 @@  cleanup:
   gfc_free_expr (expr);
   return MATCH_ERROR;
 }
-
-
-/******************** FORALL subroutines ********************/
-
-/* Free a list of FORALL iterators.  */
-
-void
-gfc_free_forall_iterator (gfc_forall_iterator *iter)
-{
-  gfc_forall_iterator *next;
-
-  while (iter)
-    {
-      next = iter->next;
-      gfc_free_expr (iter->var);
-      gfc_free_expr (iter->start);
-      gfc_free_expr (iter->end);
-      gfc_free_expr (iter->stride);
-      free (iter);
-      iter = next;
-    }
-}
-
-
-/* Match an iterator as part of a FORALL statement.  The format is:
-
-     <var> = <start>:<end>[:<stride>]
-
-   On MATCH_NO, the caller tests for the possibility that there is a
-   scalar mask expression.  */
-
-static match
-match_forall_iterator (gfc_forall_iterator **result)
-{
-  gfc_forall_iterator *iter;
-  locus where;
-  match m;
-
-  where = gfc_current_locus;
-  iter = XCNEW (gfc_forall_iterator);
-
-  m = gfc_match_expr (&iter->var);
-  if (m != MATCH_YES)
-    goto cleanup;
-
-  if (gfc_match_char ('=') != MATCH_YES
-      || iter->var->expr_type != EXPR_VARIABLE)
-    {
-      m = MATCH_NO;
-      goto cleanup;
-    }
-
-  m = gfc_match_expr (&iter->start);
-  if (m != MATCH_YES)
-    goto cleanup;
-
-  if (gfc_match_char (':') != MATCH_YES)
-    goto syntax;
-
-  m = gfc_match_expr (&iter->end);
-  if (m == MATCH_NO)
-    goto syntax;
-  if (m == MATCH_ERROR)
-    goto cleanup;
-
-  if (gfc_match_char (':') == MATCH_NO)
-    iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
-  else
-    {
-      m = gfc_match_expr (&iter->stride);
-      if (m == MATCH_NO)
-	goto syntax;
-      if (m == MATCH_ERROR)
-	goto cleanup;
-    }
-
-  /* Mark the iteration variable's symbol as used as a FORALL index.  */
-  iter->var->symtree->n.sym->forall_index = true;
-
-  *result = iter;
-  return MATCH_YES;
-
-syntax:
-  gfc_error ("Syntax error in FORALL iterator at %C");
-  m = MATCH_ERROR;
-
-cleanup:
-
-  gfc_current_locus = where;
-  gfc_free_forall_iterator (iter);
-  return m;
-}
-
-
-/* Match the header of a FORALL statement.  */
-
-static match
-match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
-{
-  gfc_forall_iterator *head, *tail, *new_iter;
-  gfc_expr *msk;
-  match m;
-
-  gfc_gobble_whitespace ();
-
-  head = tail = NULL;
-  msk = NULL;
-
-  if (gfc_match_char ('(') != MATCH_YES)
-    return MATCH_NO;
-
-  m = match_forall_iterator (&new_iter);
-  if (m == MATCH_ERROR)
-    goto cleanup;
-  if (m == MATCH_NO)
-    goto syntax;
-
-  head = tail = new_iter;
-
-  for (;;)
-    {
-      if (gfc_match_char (',') != MATCH_YES)
-	break;
-
-      m = match_forall_iterator (&new_iter);
-      if (m == MATCH_ERROR)
-	goto cleanup;
-
-      if (m == MATCH_YES)
-	{
-	  tail->next = new_iter;
-	  tail = new_iter;
-	  continue;
-	}
-
-      /* Have to have a mask expression.  */
-
-      m = gfc_match_expr (&msk);
-      if (m == MATCH_NO)
-	goto syntax;
-      if (m == MATCH_ERROR)
-	goto cleanup;
-
-      break;
-    }
-
-  if (gfc_match_char (')') == MATCH_NO)
-    goto syntax;
-
-  *phead = head;
-  *mask = msk;
-  return MATCH_YES;
-
-syntax:
-  gfc_syntax_error (ST_FORALL);
-
-cleanup:
-  gfc_free_expr (msk);
-  gfc_free_forall_iterator (head);
-
-  return MATCH_ERROR;
-}
-
-/* Match the rest of a simple FORALL statement that follows an 
-   IF statement.  */
-
-static match
-match_simple_forall (void)
-{
-  gfc_forall_iterator *head;
-  gfc_expr *mask;
-  gfc_code *c;
-  match m;
-
-  mask = NULL;
-  head = NULL;
-  c = NULL;
-
-  m = match_forall_header (&head, &mask);
-
-  if (m == MATCH_NO)
-    goto syntax;
-  if (m != MATCH_YES)
-    goto cleanup;
-
-  m = gfc_match_assignment ();
-
-  if (m == MATCH_ERROR)
-    goto cleanup;
-  if (m == MATCH_NO)
-    {
-      m = gfc_match_pointer_assignment ();
-      if (m == MATCH_ERROR)
-	goto cleanup;
-      if (m == MATCH_NO)
-	goto syntax;
-    }
-
-  c = gfc_get_code ();
-  *c = new_st;
-  c->loc = gfc_current_locus;
-
-  if (gfc_match_eos () != MATCH_YES)
-    goto syntax;
-
-  gfc_clear_new_st ();
-  new_st.op = EXEC_FORALL;
-  new_st.expr1 = mask;
-  new_st.ext.forall_iterator = head;
-  new_st.block = gfc_get_code ();
-
-  new_st.block->op = EXEC_FORALL;
-  new_st.block->next = c;
-
-  return MATCH_YES;
-
-syntax:
-  gfc_syntax_error (ST_FORALL);
-
-cleanup:
-  gfc_free_forall_iterator (head);
-  gfc_free_expr (mask);
-
-  return MATCH_ERROR;
-}
-
-
-/* Match a FORALL statement.  */
-
-match
-gfc_match_forall (gfc_statement *st)
-{
-  gfc_forall_iterator *head;
-  gfc_expr *mask;
-  gfc_code *c;
-  match m0, m;
-
-  head = NULL;
-  mask = NULL;
-  c = NULL;
-
-  m0 = gfc_match_label ();
-  if (m0 == MATCH_ERROR)
-    return MATCH_ERROR;
-
-  m = gfc_match (" forall");
-  if (m != MATCH_YES)
-    return m;
-
-  m = match_forall_header (&head, &mask);
-  if (m == MATCH_ERROR)
-    goto cleanup;
-  if (m == MATCH_NO)
-    goto syntax;
-
-  if (gfc_match_eos () == MATCH_YES)
-    {
-      *st = ST_FORALL_BLOCK;
-      new_st.op = EXEC_FORALL;
-      new_st.expr1 = mask;
-      new_st.ext.forall_iterator = head;
-      return MATCH_YES;
-    }
-
-  m = gfc_match_assignment ();
-  if (m == MATCH_ERROR)
-    goto cleanup;
-  if (m == MATCH_NO)
-    {
-      m = gfc_match_pointer_assignment ();
-      if (m == MATCH_ERROR)
-	goto cleanup;
-      if (m == MATCH_NO)
-	goto syntax;
-    }
-
-  c = gfc_get_code ();
-  *c = new_st;
-  c->loc = gfc_current_locus;
-
-  gfc_clear_new_st ();
-  new_st.op = EXEC_FORALL;
-  new_st.expr1 = mask;
-  new_st.ext.forall_iterator = head;
-  new_st.block = gfc_get_code ();
-  new_st.block->op = EXEC_FORALL;
-  new_st.block->next = c;
-
-  *st = ST_FORALL;
-  return MATCH_YES;
-
-syntax:
-  gfc_syntax_error (ST_FORALL);
-
-cleanup:
-  gfc_free_forall_iterator (head);
-  gfc_free_expr (mask);
-  gfc_free_statements (c);
-  return MATCH_NO;
-}
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 9b11086..24d8960 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -3154,7 +3154,7 @@  check_do_closure (void)
     return 0;
 
   for (p = gfc_state_stack; p; p = p->previous)
-    if (p->state == COMP_DO)
+    if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
       break;
 
   if (p == NULL)
@@ -3172,7 +3172,8 @@  check_do_closure (void)
   /* At this point, the label doesn't terminate the innermost loop.
      Make sure it doesn't terminate another one.  */
   for (; p; p = p->previous)
-    if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
+    if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
+	&& p->ext.end_do_label == gfc_statement_label)
       {
 	gfc_error ("End of nonblock DO statement at %C is interwoven "
 		   "with another DO loop");
@@ -3387,7 +3388,9 @@  parse_do_block (void)
   gfc_code *top;
   gfc_state_data s;
   gfc_symtree *stree;
+  gfc_exec_op do_op;
 
+  do_op = new_st.op;
   s.ext.end_do_label = new_st.label1;
 
   if (new_st.ext.iterator != NULL)
@@ -3398,7 +3401,8 @@  parse_do_block (void)
   accept_statement (ST_DO);
 
   top = gfc_state_stack->tail;
-  push_state (&s, COMP_DO, gfc_new_block);
+  push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
+	      gfc_new_block);
 
   s.do_variable = stree;
 
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index b18056c..9e56b81 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -30,7 +30,7 @@  typedef enum
   COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
   COMP_BLOCK, COMP_ASSOCIATE, COMP_IF,
   COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
-  COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL
+  COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT
 }
 gfc_compile_state;
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 436c160..3877711 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -58,9 +58,10 @@  code_stack;
 static code_stack *cs_base = NULL;
 
 
-/* Nonzero if we're inside a FORALL block.  */
+/* Nonzero if we're inside a FORALL or DO CONCURRENT block.  */
 
 static int forall_flag;
+static int do_concurrent_flag;
 
 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */
 
@@ -3125,11 +3126,17 @@  resolve_function (gfc_expr *expr)
     {
       if (forall_flag)
 	{
-	  gfc_error ("reference to non-PURE function '%s' at %L inside a "
+	  gfc_error ("Reference to non-PURE function '%s' at %L inside a "
 		     "FORALL %s", name, &expr->where,
 		     forall_flag == 2 ? "mask" : "block");
 	  t = FAILURE;
 	}
+      else if (do_concurrent_flag)
+	{
+	  gfc_error ("Reference to non-PURE function '%s' at %L inside a "
+		     "DO CONCURRENT block", name, &expr->where);
+	  t = FAILURE;
+	}
       else if (gfc_pure (NULL))
 	{
 	  gfc_error ("Function reference to '%s' at %L is to a non-PURE "
@@ -3196,6 +3203,9 @@  pure_subroutine (gfc_code *c, gfc_symbol *sym)
   if (forall_flag)
     gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
 	       sym->name, &c->loc);
+  else if (do_concurrent_flag)
+    gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
+	       "PURE", sym->name, &c->loc);
   else if (gfc_pure (NULL))
     gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
 	       &c->loc);
@@ -8351,10 +8361,16 @@  resolve_branch (gfc_st_label *label, gfc_code *code)
 	 whether the label is still visible outside of the CRITICAL block,
 	 which is invalid.  */
       for (stack = cs_base; stack; stack = stack->prev)
-	if (stack->current->op == EXEC_CRITICAL
-	    && bitmap_bit_p (stack->reachable_labels, label->value))
-	  gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
-		      " at %L", &code->loc, &label->where);
+	{
+	  if (stack->current->op == EXEC_CRITICAL
+	      && bitmap_bit_p (stack->reachable_labels, label->value))
+	    gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
+		      "label at %L", &code->loc, &label->where);
+	  else if (stack->current->op == EXEC_DO_CONCURRENT
+		   && bitmap_bit_p (stack->reachable_labels, label->value))
+	    gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
+		      "for label at %L", &code->loc, &label->where);
+	}
 
       return;
     }
@@ -8375,6 +8391,12 @@  resolve_branch (gfc_st_label *label, gfc_code *code)
 		      " at %L", &code->loc, &label->where);
 	  return;
 	}
+      else if (stack->current->op == EXEC_DO_CONCURRENT)
+	{
+	  gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
+		     "label at %L", &code->loc, &label->where);
+	  return;
+	}
     }
 
   if (stack)
@@ -8798,6 +8820,7 @@  gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
 	case EXEC_FORALL:
 	case EXEC_DO:
 	case EXEC_DO_WHILE:
+	case EXEC_DO_CONCURRENT:
 	case EXEC_CRITICAL:
 	case EXEC_READ:
 	case EXEC_WRITE:
@@ -9037,7 +9060,7 @@  static void
 resolve_code (gfc_code *code, gfc_namespace *ns)
 {
   int omp_workshare_save;
-  int forall_save;
+  int forall_save, do_concurrent_save;
   code_stack frame;
   gfc_try t;
 
@@ -9051,6 +9074,7 @@  resolve_code (gfc_code *code, gfc_namespace *ns)
     {
       frame.current = code;
       forall_save = forall_flag;
+      do_concurrent_save = do_concurrent_flag;
 
       if (code->op == EXEC_FORALL)
 	{
@@ -9083,6 +9107,11 @@  resolve_code (gfc_code *code, gfc_namespace *ns)
 	      /* Blocks are handled in resolve_select_type because we have
 		 to transform the SELECT TYPE into ASSOCIATE first.  */
 	      break;
+            case EXEC_DO_CONCURRENT:
+	      do_concurrent_flag = 1;
+	      gfc_resolve_blocks (code->block, ns);
+	      do_concurrent_flag = 2;
+	      break;
 	    case EXEC_OMP_WORKSHARE:
 	      omp_workshare_save = omp_workshare_flag;
 	      omp_workshare_flag = 1;
@@ -9100,6 +9129,7 @@  resolve_code (gfc_code *code, gfc_namespace *ns)
       if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
 	t = gfc_resolve_expr (code->expr1);
       forall_flag = forall_save;
+      do_concurrent_flag = do_concurrent_save;
 
       if (gfc_resolve_expr (code->expr2) == FAILURE)
 	t = FAILURE;
@@ -9367,6 +9397,7 @@  resolve_code (gfc_code *code, gfc_namespace *ns)
 	  resolve_transfer (code);
 	  break;
 
+	case EXEC_DO_CONCURRENT:
 	case EXEC_FORALL:
 	  resolve_forall_iterators (code->ext.forall_iterator);
 
@@ -13536,6 +13567,7 @@  resolve_types (gfc_namespace *ns)
     }
 
   forall_flag = 0;
+  do_concurrent_flag = 0;
   gfc_check_interfaces (ns);
 
   gfc_traverse_ns (ns, resolve_values);
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index 572baaf..932c942 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -178,6 +178,7 @@  gfc_free_statement (gfc_code *p)
 	 be freed.  */
       break;
 
+    case EXEC_DO_CONCURRENT:
     case EXEC_FORALL:
       gfc_free_forall_iterator (p->ext.forall_iterator);
       break;
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 7d8b4e0..f811089 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -3829,6 +3829,15 @@  tree gfc_trans_forall (gfc_code * code)
 }
 
 
+/* Translate the DO CONCURRENT construct.  */
+
+tree gfc_trans_do_concurrent (gfc_code * code)
+{
+  gfc_error ("Sorry, DO CONCURRENT at %L is not yet implemented", &(code->loc));
+  return NULL_TREE;
+}
+
+
 /* Evaluate the WHERE mask expression, copy its value to a temporary.
    If the WHERE construct is nested in FORALL, compute the overall temporary
    needed by the WHERE mask expression multiplied by the iterator number of
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 2d0faf1..caa4c98 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -51,6 +51,7 @@  tree gfc_trans_if (gfc_code *);
 tree gfc_trans_arithmetic_if (gfc_code *);
 tree gfc_trans_block_construct (gfc_code *);
 tree gfc_trans_do (gfc_code *, tree);
+tree gfc_trans_do_concurrent (gfc_code *);
 tree gfc_trans_do_while (gfc_code *);
 tree gfc_trans_select (gfc_code *);
 tree gfc_trans_sync (gfc_code *, gfc_exec_op);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 4a71c43..764bdf4 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1303,6 +1303,10 @@  trans_code (gfc_code * code, tree cond)
 	  res = gfc_trans_do (code, cond);
 	  break;
 
+	case EXEC_DO_CONCURRENT:
+	  res = gfc_trans_do_concurrent (code);
+	  break;
+
 	case EXEC_DO_WHILE:
 	  res = gfc_trans_do_while (code);
 	  break;
--- /dev/null	2011-09-03 12:56:10.495886960 +0200
+++ gcc/gcc/testsuite/gfortran.dg/do_concurrent_1.f90	2011-09-03 13:05:59.000000000 +0200
@@ -0,0 +1,67 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/44646
+!
+! DO CONCURRENT
+!
+implicit none
+integer :: i, j
+
+outer: do, concurrent ( i = 1 : 4)
+  do j = 1, 5
+    if (j == 1) cycle ! OK
+    cycle outer ! OK: C821   FIXME
+    exit outer ! { dg-error "EXIT statement at .1. leaves DO CONCURRENT construct" }
+  end do
+end do outer
+
+outer2: do j = 1, 7
+  do concurrent (j=1:5:2) ! cycle outer2 - bad: C821
+    cycle outer2 ! { dg-error "leaves DO CONCURRENT construct" }
+  end do
+end do outer2
+
+do concurrent ( i = 1 : 4)
+  exit ! { dg-error "EXIT statement at .1. leaves DO CONCURRENT construct" }
+end do
+end
+
+subroutine foo()
+  do concurrent ( i = 1 : 4)
+    return   ! { dg-error "Image control statement RETURN" }
+    sync all ! { dg-error "Image control statement SYNC" }
+    call test () ! { dg-error "Subroutine call to .test. in DO CONCURRENT block at .1. is not PURE" }
+    stop ! { dg-error "Image control statement STOP" }
+  end do
+  do concurrent ( i = 1 : 4)
+    critical ! { dg-error "Image control statement CRITICAL at .1. in DO CONCURRENT block" }
+      print *, i
+!    end critical
+  end do
+
+  critical
+    do concurrent ( i = 1 : 4) ! OK
+    end do
+  end critical
+end
+
+subroutine caf()
+  use iso_fortran_env
+  implicit none
+  type(lock_type), allocatable :: lock[:]
+  integer :: i
+  do, concurrent (i = 1:3)
+    allocate (lock[*]) ! { dg-error "ALLOCATE of coarray at .1. in DO CONCURRENT block" }
+    lock(lock) ! { dg-error "Image control statement LOCK" }
+    unlock(lock) ! { dg-error "Image control statement UNLOCK" }
+    deallocate (lock) ! { dg-error "DEALLOCATE of coarray at .1. in DO CONCURRENT block" }
+  end do
+
+  critical
+    allocate (lock[*]) ! { dg-error "ALLOCATE of coarray at .1. in CRITICAL block" }
+    lock(lock) ! { dg-error "Image control statement LOCK" }
+    unlock(lock) ! { dg-error "Image control statement UNLOCK" }
+    deallocate (lock) ! { dg-error "DEALLOCATE of coarray at .1. in CRITICAL block" }
+  end critical
+end subroutine caf