Patchwork [Fortran] PR44646 - Add parser support for DO CONCURRENT

login
register
mail settings
Submitter Tobias Burnus
Date Sept. 5, 2011, 4:11 p.m.
Message ID <4E64F4C3.6030406@net-b.de>
Download mbox | patch
Permalink /patch/113389/
State New
Headers show

Comments

Tobias Burnus - Sept. 5, 2011, 4:11 p.m.
On 09/03/2011 02:49 PM, Tobias Burnus wrote:
> 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

(Side remark: do concurrent also supports a logical mask expression as 
FORALL does.)


I have attached an updated version, which actually implements do 
concurrent in trans-stmt.c. Additionally, "CYCLE" without a label did 
not work.

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

Tobias
Mikael Morin - Sept. 7, 2011, 10:37 p.m.
On Monday 05 September 2011 18:11:47 Tobias Burnus wrote:
> On 09/03/2011 02:49 PM, Tobias Burnus wrote:
> > 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
> 
> (Side remark: do concurrent also supports a logical mask expression as 
> FORALL does.)
> 
> 
> I have attached an updated version, which actually implements do 
> concurrent in trans-stmt.c. Additionally, "CYCLE" without a label did 
> not work.
> 
> > Build and regtested on x86-64-linux.
> > OK for the trunk?
Patch is basically OK. One comment below.





> 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
> @@ -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;
> +       }
You could distinguish between mask and block here, like it is done for forall 
just above, or you could decide that mask is part of the do concurrent block 
and keep the error message as is (it is more i18n/gettext friendly), in which 
case you don't need to set do_concurrent_flag to 2 (hunk below). 
I'm undecided about which is the better one.

> @@ -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;


Thanks for the patch

Mikael
Thomas Koenig - Sept. 8, 2011, 4:48 a.m.
Hi Tobias,

> I have attached an updated version, which actually implements do
> concurrent in trans-stmt.c. Additionally, "CYCLE" without a label did
> not work.

I think you also need to add support to frontend-passes.c.

Regards

	Thomas
Tobias Burnus - Sept. 8, 2011, 6:41 a.m.
Mikael Morin wrote:
> Patch is basically OK. One comment below.
>
>> 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
>> @@ -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");
>> +      else if (do_concurrent_flag)
>> +         gfc_error ("Reference to non-PURE function '%s' at %L inside a "
>> +                    "DO CONCURRENT block", name,&expr->where);
> You could distinguish between mask and block here, like it is done for forall
> just above

I have changed it to be in the line with FORALL.

I have also added EXEC_DO_CONCURRENT after EXEC_FORALL in 
frontend-optimization.c as suggested by Thomas.

Committed as Rev. 178677.

Thanks for the thorough review!

Tobias

Patch

2011-09-06  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.
	(gfc_trans_forall_1): Handle do concurrent.
	* trans-stmt.h (gfc_trans_do_concurrent): New function prototype.
	* trans.c (trans_code): Call it.

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

	PR fortran/44646
	* gfortran.dg/do_concurrent_1.f90: New.
	* gfortran.dg/do_concurrent_2.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..4ea98b6 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,7 +2529,17 @@  match_exit_cycle (gfc_statement st, gfc_exec_op op)
 		  gfc_ascii_statement (st));
 	return MATCH_ERROR;
       }
-    else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO))
+    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
+			  || p->state == COMP_DO_CONCURRENT)))
       break;
 
   if (p == NULL)
@@ -2071,6 +2558,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 +2690,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 +2818,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 +2834,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 +3034,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 +3413,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 +3507,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 +3876,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 +4001,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 +5607,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..1fdb059 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -3514,6 +3514,7 @@  gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
   tree maskindex;
   tree mask;
   tree pmask;
+  tree cycle_label = NULL_TREE;
   int n;
   int nvar;
   int need_temp;
@@ -3703,6 +3704,26 @@  gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
       gfc_add_expr_to_block (&block, tmp);
     }
 
+  if (code->op == EXEC_DO_CONCURRENT)
+    {
+      gfc_init_block (&body);
+      cycle_label = gfc_build_label_decl (NULL_TREE);
+      code->cycle_label = cycle_label;
+      tmp = gfc_trans_code (code->block->next);
+      gfc_add_expr_to_block (&body, tmp);
+
+      if (TREE_USED (cycle_label))
+	{
+	  tmp = build1_v (LABEL_EXPR, cycle_label);
+	  gfc_add_expr_to_block (&body, tmp);
+	}
+
+      tmp = gfc_finish_block (&body);
+      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
+      gfc_add_expr_to_block (&block, tmp);
+      goto done;
+    }
+
   c = code->block->next;
 
   /* TODO: loop merging in FORALL statements.  */
@@ -3783,6 +3804,7 @@  gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
       c = c->next;
     }
 
+done:
   /* Restore the original index variables.  */
   for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
     gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
@@ -3829,6 +3851,14 @@  tree gfc_trans_forall (gfc_code * code)
 }
 
 
+/* Translate the DO CONCURRENT construct.  */
+
+tree gfc_trans_do_concurrent (gfc_code * code)
+{
+  return gfc_trans_forall_1 (code, NULL);
+}
+
+
 /* 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-05 08:32:03.622741340 +0200
+++ gcc/gcc/testsuite/gfortran.dg/do_concurrent_1.f90	2011-09-05 16:44:56.000000000 +0200
@@ -0,0 +1,71 @@ 
+! { 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
+
+do concurrent (j = 1:5)
+  cycle ! OK
+end do
+
+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
--- /dev/null	2011-09-05 08:32:03.622741340 +0200
+++ gcc/gcc/testsuite/gfortran.dg/do_concurrent_2.f90	2011-09-05 17:07:18.000000000 +0200
@@ -0,0 +1,40 @@ 
+! { dg-do run }
+!
+! PR fortran/44646
+!
+! DO CONCURRENT
+!
+implicit none
+integer :: i, j
+integer :: A(5,5)
+
+A = 0.0
+do concurrent (i=1:5, j=1:5, (i/=j))
+  if (i == 5) cycle
+  A(i,j) = i*j
+end do
+
+if (any (A(:,1) /= [0,  2,  3,  4, 0])) call abort()
+if (any (A(:,2) /= [2,  0,  6,  8, 0])) call abort()
+if (any (A(:,3) /= [3,  6,  0, 12, 0])) call abort()
+if (any (A(:,4) /= [4,  8, 12,  0, 0])) call abort()
+if (any (A(:,5) /= [5, 10, 15, 20, 0])) call abort()
+
+A = -99
+
+do concurrent (i = 1 : 5)
+  forall (j=1:4, i/=j)
+    A(i,j) = i*j
+  end forall
+  if (i == 5) then
+    A(i,i) = -i
+  end if
+end do
+
+if (any (A(:,1) /= [-99,   2,   3,   4,  5])) call abort ()
+if (any (A(:,2) /= [  2, -99,   6,   8, 10])) call abort ()
+if (any (A(:,3) /= [  3,   6, -99,  12, 15])) call abort ()
+if (any (A(:,4) /= [  4,   8,  12, -99, 20])) call abort ()
+if (any (A(:,5) /= [-99, -99, -99, -99, -5])) call abort ()
+
+end