[PATCH] Add support for OpenMP fortran user defined reductions

Jakub Jelinek jakub@redhat.com
Mon Jun 2 14:36:00 GMT 2014


Hi!

This patch adds UDR support to Fortran FE.  Tested on x86_64-linux,
does this look ok?

2014-06-02  Jakub Jelinek  <jakub@redhat.com>

gcc/fortran/
	* dump-parse-tree.c (show_omp_namelist): Dump reduction
	id in each list item.
	(show_omp_node): Only handle OMP_LIST_REDUCTION, not
	OMP_LIST_REDUCTION_FIRST .. OMP_LIST_REDUCTION_LAST.  Don't
	dump reduction id here.
	* frontend-passes.c (dummy_code_callback): Renamed to...
	(gfc_dummy_code_callback): ... this.  No longer static.
	(optimize_reduction): Use gfc_dummy_code_callback instead of
	dummy_code_callback.
	* gfortran.h (gfc_statement): Add ST_OMP_DECLARE_REDUCTION.
	(symbol_attribute): Add omp_udr_artificial_var bitfield.
	(gfc_omp_reduction_op): New enum.
	(gfc_omp_namelist): Add rop and udr fields.
	(OMP_LIST_PLUS, OMP_LIST_REDUCTION_FIRST, OMP_LIST_MULT,
	OMP_LIST_SUB, OMP_LIST_AND, OMP_LIST_OR, OMP_LIST_EQV,
	OMP_LIST_NEQV, OMP_LIST_MAX, OMP_LIST_MIN, OMP_LIST_IAND,
	OMP_LIST_IOR, OMP_LIST_IEOR, OMP_LIST_REDUCTION_LAST): Removed.
	(OMP_LIST_REDUCTION): New.
	(gfc_omp_udr): New type.
	(gfc_get_omp_udr): Define.
	(gfc_symtree): Add n.omp_udr field.
	(gfc_namespace): Add omp_udr_root field, add omp_udr_ns bitfield.
	(gfc_free_omp_udr, gfc_omp_udr_find, gfc_resolve_omp_udrs,
	gfc_dummy_code_callback): New prototypes.
	* match.h (gfc_match_omp_declare_reduction): New prototype.
	* module.c (MOD_VERSION): Increase to 13.
	(omp_declare_reduction_stmt): New array.
	(mio_omp_udr_expr, write_omp_udr, write_omp_udrs, load_omp_udrs):
	New functions.
	(read_module): Read OpenMP user defined reductions.
	(write_module): Write OpenMP user defined reductions.
	* openmp.c: Include arith.h.
	(gfc_free_omp_udr, gfc_find_omp_udr): New functions.
	(gfc_match_omp_clauses): Handle user defined reductions.
	Store reduction kind into gfc_omp_namelist instead of using
	several OMP_LIST_* entries.
	(match_udr_expr, gfc_omp_udr_predef, gfc_omp_udr_find,
	gfc_match_omp_declare_reduction): New functions.
	(resolve_omp_clauses): Adjust for reduction clauses being only
	in OMP_LIST_REDUCTION list.  Diagnose missing UDRs.
	(struct omp_udr_callback_data): New type.
	(omp_udr_callback, gfc_resolve_omp_udr, gfc_resolve_omp_udrs): New
	functions.
	* parse.c (decode_omp_directive): Handle !$omp declare reduction.
	(case_decl): Add ST_OMP_DECLARE_REDUCTION.
	(gfc_ascii_statement): Print ST_OMP_DECLARE_REDUCTION.
	* resolve.c (resolve_fl_variable): Allow len=: or len=* on
	sym->attr.omp_udr_artificial_var symbols.
	(resolve_types): Call gfc_resolve_omp_udrs.
	* symbol.c (gfc_get_uop): If gfc_current_ns->omp_udr_ns,
	use parent ns instead of gfc_current_ns.
	(gfc_get_sym_tree): Don't insert symbols into
	namespaces with omp_udr_ns set.
	(free_omp_udr_tree): New function.
	(gfc_free_namespace): Call it.
	* trans-openmp.c (struct omp_udr_find_orig_data): New type.
	(omp_udr_find_orig, gfc_trans_omp_udr_expr): New functions.
	(gfc_trans_omp_array_reduction): Renamed to...
	(gfc_trans_omp_array_reduction_or_udr): ... this.  Remove SYM
	argument, instead pass gfc_omp_namelist pointer N.  Handle
	user defined reductions.
	(gfc_trans_omp_reduction_list): Remove REDUCTION_CODE argument.
	Handle user defined reductions and reduction ops in gfc_omp_namelist.
	(gfc_trans_omp_clauses): Adjust for just a single OMP_LIST_REDUCTION
	list.
	(gfc_split_omp_clauses): Likewise.
gcc/testsuite/
	* gfortran.dg/gomp/allocatable_components_1.f90: Adjust for
	reduction clause diagnostic changes.
	* gfortran.dg/gomp/appendix-a/a.31.3.f90: Likewise.
	* gfortran.dg/gomp/reduction1.f90: Likewise.
	* gfortran.dg/gomp/reduction3.f90: Likewise.
	* gfortran.dg/gomp/udr1.f90: New test.
	* gfortran.dg/gomp/udr2.f90: New test.
	* gfortran.dg/gomp/udr3.f90: New test.
	* gfortran.dg/gomp/udr4.f90: New test.
	* gfortran.dg/gomp/udr5.f90: New test.
	* gfortran.dg/gomp/udr6.f90: New test.
	* gfortran.dg/gomp/udr7.f90: New test.
libgomp/
	* testsuite/libgomp.fortran/simd1.f90: New test.
	* testsuite/libgomp.fortran/udr1.f90: New test.
	* testsuite/libgomp.fortran/udr2.f90: New test.
	* testsuite/libgomp.fortran/udr3.f90: New test.
	* testsuite/libgomp.fortran/udr4.f90: New test.
	* testsuite/libgomp.fortran/udr5.f90: New test.
	* testsuite/libgomp.fortran/udr6.f90: New test.
	* testsuite/libgomp.fortran/udr7.f90: New test.
	* testsuite/libgomp.fortran/udr8.f90: New test.
	* testsuite/libgomp.fortran/udr9.f90: New test.
	* testsuite/libgomp.fortran/udr10.f90: New test.
	* testsuite/libgomp.fortran/udr11.f90: New test.

--- gcc/fortran/dump-parse-tree.c.jj	2014-05-30 20:33:49.394060821 +0200
+++ gcc/fortran/dump-parse-tree.c	2014-06-02 10:36:19.655285301 +0200
@@ -1020,6 +1020,28 @@ show_omp_namelist (gfc_omp_namelist *n)
 {
   for (; n; n = n->next)
     {
+      switch (n->rop)
+	{
+	case OMP_REDUCTION_PLUS:
+	case OMP_REDUCTION_TIMES:
+	case OMP_REDUCTION_MINUS:
+	case OMP_REDUCTION_AND:
+	case OMP_REDUCTION_OR:
+	case OMP_REDUCTION_EQV:
+	case OMP_REDUCTION_NEQV:
+	  fprintf (dumpfile, "%s:", gfc_op2string ((gfc_intrinsic_op) n->rop));
+	  break;
+	case OMP_REDUCTION_MAX: fputs ("max:", dumpfile); break;
+	case OMP_REDUCTION_MIN: fputs ("min:", dumpfile); break;
+	case OMP_REDUCTION_IAND: fputs ("iand:", dumpfile); break;
+	case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break;
+	case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break;
+	case OMP_REDUCTION_USER:
+	  if (n->udr)
+	    fprintf (dumpfile, "%s:", n->udr->name);
+	  break;
+	default: break;
+	}
       fprintf (dumpfile, "%s", n->sym->name);
       if (n->expr)
 	{
@@ -1193,51 +1215,28 @@ show_omp_node (int level, gfc_code *c)
 	    && list_type != OMP_LIST_COPYPRIVATE)
 	  {
 	    const char *type = NULL;
-	    if (list_type >= OMP_LIST_REDUCTION_FIRST)
-	      {
-		switch (list_type)
-		  {
-		  case OMP_LIST_PLUS: type = "+"; break;
-		  case OMP_LIST_MULT: type = "*"; break;
-		  case OMP_LIST_SUB: type = "-"; break;
-		  case OMP_LIST_AND: type = ".AND."; break;
-		  case OMP_LIST_OR: type = ".OR."; break;
-		  case OMP_LIST_EQV: type = ".EQV."; break;
-		  case OMP_LIST_NEQV: type = ".NEQV."; break;
-		  case OMP_LIST_MAX: type = "MAX"; break;
-		  case OMP_LIST_MIN: type = "MIN"; break;
-		  case OMP_LIST_IAND: type = "IAND"; break;
-		  case OMP_LIST_IOR: type = "IOR"; break;
-		  case OMP_LIST_IEOR: type = "IEOR"; break;
-		  default:
-		    gcc_unreachable ();
-		  }
-		fprintf (dumpfile, " REDUCTION(%s:", type);
-	      }
-	    else
+	    switch (list_type)
 	      {
-		switch (list_type)
-		  {
-		  case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
-		  case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
-		  case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
-		  case OMP_LIST_SHARED: type = "SHARED"; break;
-		  case OMP_LIST_COPYIN: type = "COPYIN"; break;
-		  case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
-		  case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
-		  case OMP_LIST_LINEAR: type = "LINEAR"; break;
-		  case OMP_LIST_DEPEND_IN:
-		    fprintf (dumpfile, " DEPEND(IN:");
-		    break;
-		  case OMP_LIST_DEPEND_OUT:
-		    fprintf (dumpfile, " DEPEND(OUT:");
-		    break;
-		  default:
-		    gcc_unreachable ();
-		  }
-		if (type)
-		  fprintf (dumpfile, " %s(", type);
+	      case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
+	      case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
+	      case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
+	      case OMP_LIST_SHARED: type = "SHARED"; break;
+	      case OMP_LIST_COPYIN: type = "COPYIN"; break;
+	      case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
+	      case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
+	      case OMP_LIST_LINEAR: type = "LINEAR"; break;
+	      case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
+	      case OMP_LIST_DEPEND_IN:
+		fprintf (dumpfile, " DEPEND(IN:");
+		break;
+	      case OMP_LIST_DEPEND_OUT:
+		fprintf (dumpfile, " DEPEND(OUT:");
+		break;
+	      default:
+		gcc_unreachable ();
 	      }
+	    if (type)
+	      fprintf (dumpfile, " %s(", type);
 	    show_omp_namelist (omp_clauses->lists[list_type]);
 	    fputc (')', dumpfile);
 	  }
--- gcc/fortran/frontend-passes.c.jj	2014-05-30 20:33:49.442060576 +0200
+++ gcc/fortran/frontend-passes.c	2014-06-02 10:36:19.676285158 +0200
@@ -676,10 +676,10 @@ dummy_expr_callback (gfc_expr **e ATTRIB
 
 /* Dummy function for code callback, for use when we really
    don't want to do anything.  */
-static int
-dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
-		     int *walk_subtrees ATTRIBUTE_UNUSED,
-		     void *data ATTRIBUTE_UNUSED)
+int
+gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
+			 int *walk_subtrees ATTRIBUTE_UNUSED,
+			 void *data ATTRIBUTE_UNUSED)
 {
   return 0;
 }
@@ -844,7 +844,8 @@ static void
 optimize_reduction (gfc_namespace *ns)
 {
   current_ns = ns;
-  gfc_code_walker (&ns->code, dummy_code_callback, callback_reduction, NULL);
+  gfc_code_walker (&ns->code, gfc_dummy_code_callback,
+		   callback_reduction, NULL);
 
 /* BLOCKs are handled in the expression walker below.  */
   for (ns = ns->contained; ns; ns = ns->sibling)
--- gcc/fortran/gfortran.h.jj	2014-05-30 20:33:49.420060689 +0200
+++ gcc/fortran/gfortran.h	2014-06-02 10:36:19.695285060 +0200
@@ -214,9 +214,9 @@ typedef enum
   ST_OMP_TASKWAIT, ST_OMP_TASKYIELD, ST_OMP_CANCEL, ST_OMP_CANCELLATION_POINT,
   ST_OMP_TASKGROUP, ST_OMP_END_TASKGROUP, ST_OMP_SIMD, ST_OMP_END_SIMD,
   ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD, ST_OMP_PARALLEL_DO_SIMD,
-  ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_PROCEDURE, ST_GENERIC,
-  ST_CRITICAL, ST_END_CRITICAL, ST_GET_FCN_CHARACTERISTICS, ST_LOCK,
-  ST_UNLOCK, ST_NONE
+  ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_REDUCTION,
+  ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
+  ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE
 }
 gfc_statement;
 
@@ -817,6 +817,10 @@ typedef struct
      variable for SELECT_TYPE or ASSOCIATE.  */
   unsigned select_type_temporary:1, associate_var:1;
 
+  /* This is omp_{out,in,priv,orig} artificial variable in
+     !$OMP DECLARE REDUCTION.  */
+  unsigned omp_udr_artificial_var:1;
+
   /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES).  */
   unsigned ext_attr:EXT_ATTR_NUM;
 
@@ -1037,6 +1041,25 @@ gfc_namelist;
 
 #define gfc_get_namelist() XCNEW (gfc_namelist)
 
+typedef enum
+{
+  OMP_REDUCTION_NONE = -1,
+  OMP_REDUCTION_PLUS = INTRINSIC_PLUS,
+  OMP_REDUCTION_MINUS = INTRINSIC_MINUS,
+  OMP_REDUCTION_TIMES = INTRINSIC_TIMES,
+  OMP_REDUCTION_AND = INTRINSIC_AND,
+  OMP_REDUCTION_OR = INTRINSIC_OR,
+  OMP_REDUCTION_EQV = INTRINSIC_EQV,
+  OMP_REDUCTION_NEQV = INTRINSIC_NEQV,
+  OMP_REDUCTION_MAX = GFC_INTRINSIC_END,
+  OMP_REDUCTION_MIN,
+  OMP_REDUCTION_IAND,
+  OMP_REDUCTION_IOR,
+  OMP_REDUCTION_IEOR,
+  OMP_REDUCTION_USER
+}
+gfc_omp_reduction_op;
+
 /* For use in OpenMP clauses in case we need extra information
    (aligned clause alignment, linear clause step, etc.).  */
 
@@ -1044,6 +1067,8 @@ typedef struct gfc_omp_namelist
 {
   struct gfc_symbol *sym;
   struct gfc_expr *expr;
+  gfc_omp_reduction_op rop;
+  struct gfc_omp_udr *udr;
   struct gfc_omp_namelist *next;
 }
 gfc_omp_namelist;
@@ -1063,20 +1088,7 @@ enum
   OMP_LIST_LINEAR,
   OMP_LIST_DEPEND_IN,
   OMP_LIST_DEPEND_OUT,
-  OMP_LIST_PLUS,
-  OMP_LIST_REDUCTION_FIRST = OMP_LIST_PLUS,
-  OMP_LIST_MULT,
-  OMP_LIST_SUB,
-  OMP_LIST_AND,
-  OMP_LIST_OR,
-  OMP_LIST_EQV,
-  OMP_LIST_NEQV,
-  OMP_LIST_MAX,
-  OMP_LIST_MIN,
-  OMP_LIST_IAND,
-  OMP_LIST_IOR,
-  OMP_LIST_IEOR,
-  OMP_LIST_REDUCTION_LAST = OMP_LIST_IEOR,
+  OMP_LIST_REDUCTION,
   OMP_LIST_NUM
 };
 
@@ -1155,6 +1167,25 @@ typedef struct gfc_omp_declare_simd
 gfc_omp_declare_simd;
 #define gfc_get_omp_declare_simd() XCNEW (gfc_omp_declare_simd)
 
+typedef struct gfc_omp_udr
+{
+  struct gfc_omp_udr *next;
+  locus where; /* Where the !$omp declare reduction construct occurred.  */
+
+  const char *name;
+  gfc_typespec ts;
+  gfc_omp_reduction_op rop;
+
+  struct gfc_symbol *omp_out;
+  struct gfc_symbol *omp_in;
+  struct gfc_namespace *combiner_ns;
+
+  struct gfc_symbol *omp_priv;
+  struct gfc_symbol *omp_orig;
+  struct gfc_namespace *initializer_ns;
+}
+gfc_omp_udr;
+#define gfc_get_omp_udr() XCNEW (gfc_omp_udr)
 
 /* The gfc_st_label structure is a BBT attached to a namespace that
    records the usage of statement labels within that space.  */
@@ -1432,6 +1463,7 @@ typedef struct gfc_symtree
     gfc_user_op *uop;
     gfc_common_head *common;
     gfc_typebound_proc *tb;
+    gfc_omp_udr *omp_udr;
   }
   n;
 }
@@ -1462,6 +1494,8 @@ typedef struct gfc_namespace
   gfc_symtree *uop_root;
   /* Tree containing all the common blocks.  */
   gfc_symtree *common_root;
+  /* Tree containing all the OpenMP user defined reductions.  */
+  gfc_symtree *omp_udr_root;
 
   /* Tree containing type-bound procedures.  */
   gfc_symtree *tb_sym_root;
@@ -1547,6 +1581,9 @@ typedef struct gfc_namespace
   /* Set to 1 if symbols in this namespace should be 'construct entities',
      i.e. for BLOCK local variables.  */
   unsigned construct_entities:1;
+
+  /* Set to 1 for !$OMP DECLARE REDUCTION namespaces.  */
+  unsigned omp_udr_ns:1;
 }
 gfc_namespace;
 
@@ -2814,11 +2851,14 @@ struct gfc_omp_saved_state { void *ptrs[
 void gfc_free_omp_clauses (gfc_omp_clauses *);
 void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
 void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
+void gfc_free_omp_udr (gfc_omp_udr *);
+gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
 void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
 void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *);
 void gfc_resolve_omp_parallel_blocks (gfc_code *, gfc_namespace *);
 void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *);
 void gfc_resolve_omp_declare_simd (gfc_namespace *);
+void gfc_resolve_omp_udrs (gfc_symtree *);
 void gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *);
 void gfc_omp_restore_state (struct gfc_omp_saved_state *);
 
@@ -3094,6 +3134,7 @@ void gfc_run_passes (gfc_namespace *);
 typedef int (*walk_code_fn_t) (gfc_code **, int *, void *);
 typedef int (*walk_expr_fn_t) (gfc_expr **, int *, void *);
 
+int gfc_dummy_code_callback (gfc_code **, int *, void *);
 int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *);
 int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *);
 
--- gcc/fortran/match.h.jj	2014-05-30 20:33:49.462060474 +0200
+++ gcc/fortran/match.h	2014-06-02 10:36:19.706285003 +0200
@@ -129,6 +129,7 @@ match gfc_match_omp_barrier (void);
 match gfc_match_omp_cancel (void);
 match gfc_match_omp_cancellation_point (void);
 match gfc_match_omp_critical (void);
+match gfc_match_omp_declare_reduction (void);
 match gfc_match_omp_declare_simd (void);
 match gfc_match_omp_do (void);
 match gfc_match_omp_do_simd (void);
--- gcc/fortran/module.c.jj	2014-05-30 20:33:49.429060643 +0200
+++ gcc/fortran/module.c	2014-06-02 16:23:21.569941713 +0200
@@ -82,7 +82,7 @@ along with GCC; see the file COPYING3.
 
 /* Don't put any single quote (') in MOD_VERSION, if you want it to be
    recognized.  */
-#define MOD_VERSION "12"
+#define MOD_VERSION "13"
 
 
 /* Structure that describes a position within a module file.  */
@@ -3896,6 +3896,98 @@ mio_omp_declare_simd (gfc_namespace *ns,
 }
 
 
+static const mstring omp_declare_reduction_stmt[] =
+{
+    minit ("ASSIGN", 0),
+    minit ("CALL", 1),
+    minit (NULL, -1)
+};
+
+
+static void
+mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
+		  gfc_namespace *ns, bool is_initializer)
+{
+  if (iomode == IO_OUTPUT)
+    {
+      if ((*sym1)->module == NULL)
+	{
+	  (*sym1)->module = module_name;
+	  (*sym2)->module = module_name;
+	}
+      mio_symbol_ref (sym1);
+      mio_symbol_ref (sym2);
+      if (ns->code->op == EXEC_ASSIGN)
+	{
+	  mio_name (0, omp_declare_reduction_stmt);
+	  mio_expr (&ns->code->expr1);
+	  mio_expr (&ns->code->expr2);
+	}
+      else
+	{
+	  int flag;
+	  mio_name (1, omp_declare_reduction_stmt);
+	  mio_symtree_ref (&ns->code->symtree);
+	  mio_actual_arglist (&ns->code->ext.actual);
+
+	  flag = ns->code->resolved_isym != NULL;
+	  mio_integer (&flag);
+	  if (flag)
+	    write_atom (ATOM_STRING, ns->code->resolved_isym->name);
+	  else
+	    mio_symbol_ref (&ns->code->resolved_sym);
+	}
+    }
+  else
+    {
+      pointer_info *p1 = mio_symbol_ref (sym1);
+      pointer_info *p2 = mio_symbol_ref (sym2);
+      gfc_symbol *sym;
+      gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns);
+      gcc_assert (p1->u.rsym.sym == NULL);
+      /* Add hidden symbols to the symtree.  */
+      pointer_info *q = get_integer (p1->u.rsym.ns);
+      q->u.pointer = (void *) ns;
+      sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
+      sym->ts = udr->ts;
+      sym->module = gfc_get_string (p1->u.rsym.module);
+      associate_integer_pointer (p1, sym);
+      sym->attr.omp_udr_artificial_var = 1;
+      gcc_assert (p2->u.rsym.sym == NULL);
+      sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
+      sym->ts = udr->ts;
+      sym->module = gfc_get_string (p2->u.rsym.module);
+      associate_integer_pointer (p2, sym);
+      sym->attr.omp_udr_artificial_var = 1;
+      if (mio_name (0, omp_declare_reduction_stmt) == 0)
+	{
+	  ns->code = gfc_get_code (EXEC_ASSIGN);
+	  mio_expr (&ns->code->expr1);
+	  mio_expr (&ns->code->expr2);
+	}
+      else
+	{
+	  int flag;
+	  ns->code = gfc_get_code (EXEC_CALL);
+	  mio_symtree_ref (&ns->code->symtree);
+	  mio_actual_arglist (&ns->code->ext.actual);
+
+	  mio_integer (&flag);
+	  if (flag)
+	    {
+	      require_atom (ATOM_STRING);
+	      ns->code->resolved_isym = gfc_find_subroutine (atom_string);
+	      free (atom_string);
+	    }
+	  else
+	    mio_symbol_ref (&ns->code->resolved_sym);
+	}
+      ns->code->loc = gfc_current_locus;
+      ns->omp_udr_ns = 1;
+    }
+}
+
+
 /* Unlike most other routines, the address of the symbol node is already
    fixed on input and the name/module has already been filled in.
    If you update the symbol format here, don't forget to update read_module
@@ -4453,6 +4545,119 @@ load_derived_extensions (void)
 }
 
 
+/* This function loads OpenMP user defined reductions.  */
+static void
+load_omp_udrs (void)
+{
+  mio_lparen ();
+  while (peek_atom () != ATOM_RPAREN)
+    {
+      const char *name, *newname;
+      char *altname;
+      gfc_typespec ts;
+      gfc_symtree *st;
+      gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
+
+      mio_lparen ();
+      mio_pool_string (&name);
+      mio_typespec (&ts);
+      if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0)
+	{
+	  const char *p = name + sizeof ("operator ") - 1;
+	  if (strcmp (p, "+") == 0)
+	    rop = OMP_REDUCTION_PLUS;
+	  else if (strcmp (p, "*") == 0)
+	    rop = OMP_REDUCTION_TIMES;
+	  else if (strcmp (p, "-") == 0)
+	    rop = OMP_REDUCTION_MINUS;
+	  else if (strcmp (p, ".and.") == 0)
+	    rop = OMP_REDUCTION_AND;
+	  else if (strcmp (p, ".or.") == 0)
+	    rop = OMP_REDUCTION_OR;
+	  else if (strcmp (p, ".eqv.") == 0)
+	    rop = OMP_REDUCTION_EQV;
+	  else if (strcmp (p, ".neqv.") == 0)
+	    rop = OMP_REDUCTION_NEQV;
+	}
+      altname = NULL;
+      if (rop == OMP_REDUCTION_USER && name[0] == '.')
+	{
+	  size_t len = strlen (name + 1);
+	  altname = XALLOCAVEC (char, len);
+	  gcc_assert (name[len] == '.');
+	  memcpy (altname, name + 1, len - 1);
+	  altname[len - 1] = '\0';
+	}
+      newname = name;
+      if (rop == OMP_REDUCTION_USER)
+	newname = find_use_name (altname ? altname : name, !!altname);
+      else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL)
+	newname = NULL;
+      if (newname == NULL)
+	{
+	  skip_list (1);
+	  continue;
+	}
+      if (altname && newname != altname)
+	{
+	  size_t len = strlen (newname);
+	  altname = XALLOCAVEC (char, len + 3);
+	  altname[0] = '.';
+	  memcpy (altname + 1, newname, len);
+	  altname[len + 1] = '.';
+	  altname[len + 2] = '\0';
+	  name = gfc_get_string (altname);
+	}
+      st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
+      gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
+      if (udr)
+	{
+	  require_atom (ATOM_INTEGER);
+	  pointer_info *p = get_integer (atom_int);
+	  if (strcmp (p->u.rsym.module, udr->omp_out->module))
+	    {
+	      gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
+			 "module %s at %L",
+			 p->u.rsym.module, &gfc_current_locus);
+	      gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
+			 "%s at %L",
+			 udr->omp_out->module, &udr->where);
+	    }
+	  skip_list (1);
+	  continue;
+	}
+      udr = gfc_get_omp_udr ();
+      udr->name = name;
+      udr->rop = rop;
+      udr->ts = ts;
+      udr->where = gfc_current_locus;
+      udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
+      udr->combiner_ns->proc_name = gfc_current_ns->proc_name;
+      mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns,
+			false);
+      if (peek_atom () != ATOM_RPAREN)
+	{
+	  udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
+	  udr->initializer_ns->proc_name = gfc_current_ns->proc_name;
+	  mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
+			    udr->initializer_ns, true);
+	}
+      if (st)
+	{
+	  udr->next = st->n.omp_udr;
+	  st->n.omp_udr = udr;
+	}
+      else
+	{
+	  st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
+	  st->n.omp_udr = udr;
+	}
+      mio_rparen ();
+    }
+  mio_rparen ();
+}
+
+
 /* Recursive function to traverse the pointer_info tree and load a
    needed symbol.  We return nonzero if we load a symbol and stop the
    traversal, because the act of loading can alter the tree.  */
@@ -4640,7 +4845,7 @@ check_for_ambiguous (gfc_symbol *st_sym,
 static void
 read_module (void)
 {
-  module_locus operator_interfaces, user_operators, extensions;
+  module_locus operator_interfaces, user_operators, extensions, omp_udrs;
   const char *p;
   char name[GFC_MAX_SYMBOL_LEN + 1];
   int i;
@@ -4664,6 +4869,10 @@ read_module (void)
   get_module_locus (&extensions);
   skip_list ();
 
+  /* Skip OpenMP UDRs.  */
+  get_module_locus (&omp_udrs);
+  skip_list ();
+
   mio_lparen ();
 
   /* Create the fixup nodes for all the symbols.  */
@@ -4929,6 +5138,10 @@ read_module (void)
   load_commons ();
   load_equiv ();
 
+  /* Load OpenMP user defined reductions.  */
+  set_module_locus (&omp_udrs);
+  load_omp_udrs ();
+
   /* At this point, we read those symbols that are needed but haven't
      been loaded yet.  If one symbol requires another, the other gets
      marked as NEEDED if its previous state was UNUSED.  */
@@ -5307,6 +5520,80 @@ write_symbol0 (gfc_symtree *st)
 }
 
 
+static void
+write_omp_udr (gfc_omp_udr *udr)
+{
+  switch (udr->rop)
+    {
+    case OMP_REDUCTION_USER:
+      /* Non-operators can't be used outside of the module.  */
+      if (udr->name[0] != '.')
+	return;
+      else
+	{
+	  gfc_symtree *st;
+	  size_t len = strlen (udr->name + 1);
+	  char *name = XALLOCAVEC (char, len);
+	  memcpy (name, udr->name, len - 1);
+	  name[len - 1] = '\0';
+	  st = gfc_find_symtree (gfc_current_ns->uop_root, name);
+	  /* If corresponding user operator is private, don't write
+	     the UDR.  */
+	  if (st != NULL)
+	    {
+	      gfc_user_op *uop = st->n.uop;
+	      if (!check_access (uop->access, uop->ns->default_access))
+		return;
+	    }
+	}
+      break;
+    case OMP_REDUCTION_PLUS:
+    case OMP_REDUCTION_MINUS:
+    case OMP_REDUCTION_TIMES:
+    case OMP_REDUCTION_AND:
+    case OMP_REDUCTION_OR:
+    case OMP_REDUCTION_EQV:
+    case OMP_REDUCTION_NEQV:
+      /* If corresponding operator is private, don't write the UDR.  */
+      if (!check_access (gfc_current_ns->operator_access[udr->rop],
+			 gfc_current_ns->default_access))
+	return;
+      break;
+    default:
+      break;
+    }
+  if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS)
+    {
+      /* If derived type is private, don't write the UDR.  */
+      if (!gfc_check_symbol_access (udr->ts.u.derived))
+	return;
+    }
+
+  mio_lparen ();
+  mio_pool_string (&udr->name);
+  mio_typespec (&udr->ts);
+  mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false);
+  if (udr->initializer_ns)
+    mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
+		      udr->initializer_ns, true);
+  mio_rparen ();
+}
+
+
+static void
+write_omp_udrs (gfc_symtree *st)
+{
+  if (st == NULL)
+    return;
+
+  write_omp_udrs (st->left);
+  gfc_omp_udr *udr;
+  for (udr = st->n.omp_udr; udr; udr = udr->next)
+    write_omp_udr (udr);
+  write_omp_udrs (st->right);
+}
+
+
 /* Type for the temporary tree used when writing secondary symbols.  */
 
 struct sorted_pointer_info
@@ -5554,6 +5841,12 @@ write_module (void)
   mio_rparen ();
   write_char ('\n');
   write_char ('\n');
+
+  mio_lparen ();
+  write_omp_udrs (gfc_current_ns->omp_udr_root);
+  mio_rparen ();
+  write_char ('\n');
+  write_char ('\n');
 
   /* Write symbol information.  First we traverse all symbols in the
      primary namespace, writing those that need to be written.
--- gcc/fortran/openmp.c.jj	2014-05-30 20:33:49.481060376 +0200
+++ gcc/fortran/openmp.c	2014-06-02 15:33:11.781117656 +0200
@@ -23,6 +23,7 @@ along with GCC; see the file COPYING3.
 #include "coretypes.h"
 #include "flags.h"
 #include "gfortran.h"
+#include "arith.h"
 #include "match.h"
 #include "parse.h"
 #include "pointer-set.h"
@@ -99,6 +100,66 @@ gfc_free_omp_declare_simd_list (gfc_omp_
     }
 }
 
+/* Free an !$omp declare reduction.  */
+
+void
+gfc_free_omp_udr (gfc_omp_udr *omp_udr)
+{
+  if (omp_udr)
+    {
+      gfc_free_omp_udr (omp_udr->next);
+      gfc_free_namespace (omp_udr->combiner_ns);
+      if (omp_udr->initializer_ns)
+	gfc_free_namespace (omp_udr->initializer_ns);
+      free (omp_udr);
+    }
+}
+
+
+static gfc_omp_udr *
+gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
+{
+  gfc_symtree *st;
+
+  if (ns == NULL)
+    ns = gfc_current_ns;
+  do
+    {
+      gfc_omp_udr *omp_udr;
+
+      st = gfc_find_symtree (ns->omp_udr_root, name);
+      if (st != NULL)
+	for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
+	  if (ts == NULL)
+	    return omp_udr;
+	  else if (gfc_compare_types (&omp_udr->ts, ts))
+	    {
+	      if (ts->type == BT_CHARACTER)
+		{
+		  if (omp_udr->ts.u.cl->length == NULL)
+		    return omp_udr;
+		  if (ts->u.cl->length == NULL)
+		    continue;
+		  if (gfc_compare_expr (omp_udr->ts.u.cl->length,
+					ts->u.cl->length,
+					INTRINSIC_EQ) != 0)
+		    continue;
+		}
+	      return omp_udr;
+	    }
+
+      /* Don't escape an interface block.  */
+      if (ns && !ns->has_import_set
+	  && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+	break;
+
+      ns = ns->parent;
+    }
+  while (ns != NULL);
+
+  return NULL;
+}
+
 
 /* Match a variable/common block list and construct a namelist from it.  */
 
@@ -313,22 +374,30 @@ gfc_match_omp_clauses (gfc_omp_clauses *
       if ((mask & OMP_CLAUSE_REDUCTION)
 	  && gfc_match ("reduction ( ") == MATCH_YES)
 	{
-	  int reduction = OMP_LIST_NUM;
-	  char buffer[GFC_MAX_SYMBOL_LEN + 1];
+	  gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
+	  char buffer[GFC_MAX_SYMBOL_LEN + 3];
 	  if (gfc_match_char ('+') == MATCH_YES)
-	    reduction = OMP_LIST_PLUS;
+	    rop = OMP_REDUCTION_PLUS;
 	  else if (gfc_match_char ('*') == MATCH_YES)
-	    reduction = OMP_LIST_MULT;
+	    rop = OMP_REDUCTION_TIMES;
 	  else if (gfc_match_char ('-') == MATCH_YES)
-	    reduction = OMP_LIST_SUB;
+	    rop = OMP_REDUCTION_MINUS;
 	  else if (gfc_match (".and.") == MATCH_YES)
-	    reduction = OMP_LIST_AND;
+	    rop = OMP_REDUCTION_AND;
 	  else if (gfc_match (".or.") == MATCH_YES)
-	    reduction = OMP_LIST_OR;
+	    rop = OMP_REDUCTION_OR;
 	  else if (gfc_match (".eqv.") == MATCH_YES)
-	    reduction = OMP_LIST_EQV;
+	    rop = OMP_REDUCTION_EQV;
 	  else if (gfc_match (".neqv.") == MATCH_YES)
-	    reduction = OMP_LIST_NEQV;
+	    rop = OMP_REDUCTION_NEQV;
+	  if (rop != OMP_REDUCTION_NONE)
+	    snprintf (buffer, sizeof buffer,
+		      "operator %s", gfc_op2string ((gfc_intrinsic_op) rop));
+	  else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
+	    {
+	      buffer[0] = '.';
+	      strcat (buffer, ".");
+	    }
 	  else if (gfc_match_name (buffer) == MATCH_YES)
 	    {
 	      gfc_symbol *sym;
@@ -356,40 +425,60 @@ gfc_match_omp_clauses (gfc_omp_clauses *
 			   || sym->attr.if_source != IFSRC_UNKNOWN
 			   || sym == sym->ns->proc_name)
 		    {
-		      gfc_error_now ("%s is not INTRINSIC procedure name "
-				     "at %C", buffer);
 		      sym = NULL;
+		      n = NULL;
 		    }
 		  else
 		    n = sym->name;
 		}
-	      if (strcmp (n, "max") == 0)
-		reduction = OMP_LIST_MAX;
+	      if (n == NULL)
+		rop = OMP_REDUCTION_NONE;
+	      else if (strcmp (n, "max") == 0)
+		rop = OMP_REDUCTION_MAX;
 	      else if (strcmp (n, "min") == 0)
-		reduction = OMP_LIST_MIN;
+		rop = OMP_REDUCTION_MIN;
 	      else if (strcmp (n, "iand") == 0)
-		reduction = OMP_LIST_IAND;
+		rop = OMP_REDUCTION_IAND;
 	      else if (strcmp (n, "ior") == 0)
-		reduction = OMP_LIST_IOR;
+		rop = OMP_REDUCTION_IOR;
 	      else if (strcmp (n, "ieor") == 0)
-		reduction = OMP_LIST_IEOR;
-	      if (reduction != OMP_LIST_NUM
+		rop = OMP_REDUCTION_IEOR;
+	      if (rop != OMP_REDUCTION_NONE
 		  && sym != NULL
 		  && ! sym->attr.intrinsic
 		  && ! sym->attr.use_assoc
 		  && ((sym->attr.flavor == FL_UNKNOWN
-		       && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
+		       && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
+					   sym->name, NULL))
 		      || !gfc_add_intrinsic (&sym->attr, NULL)))
+		rop = OMP_REDUCTION_NONE;
+	    }
+	  gfc_omp_udr *udr = gfc_find_omp_udr (gfc_current_ns, buffer, NULL);
+	  gfc_omp_namelist **head = NULL;
+	  if (rop == OMP_REDUCTION_NONE && udr)
+	    rop = OMP_REDUCTION_USER;
+
+	  if (gfc_match_omp_variable_list (" :",
+					   &c->lists[OMP_LIST_REDUCTION],
+					   false, NULL, &head) == MATCH_YES)
+	    {
+	      gfc_omp_namelist *n;
+	      if (rop == OMP_REDUCTION_NONE)
 		{
-		  gfc_free_omp_clauses (c);
-		  return MATCH_ERROR;
+		  n = *head;
+		  *head = NULL;
+		  gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
+				 "at %L", buffer, &old_loc);
+		  gfc_free_omp_namelist (n);
 		}
+	      else
+		for (n = *head; n; n = n->next)
+		  {
+		    n->rop = rop;
+		    n->udr = udr;
+		  }
+	      continue;
 	    }
-	  if (reduction != OMP_LIST_NUM
-	      && gfc_match_omp_variable_list (" :", &c->lists[reduction],
-					      false)
-		 == MATCH_YES)
-	    continue;
 	  else
 	    gfc_current_locus = old_loc;
 	}
@@ -777,6 +866,382 @@ gfc_match_omp_declare_simd (void)
 }
 
 
+static bool
+match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
+{
+  match m;
+  locus old_loc = gfc_current_locus;
+  char sname[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol *sym;
+  gfc_namespace *ns = gfc_current_ns;
+  gfc_expr *lvalue = NULL, *rvalue = NULL;
+  gfc_symtree *st;
+  gfc_actual_arglist *arglist;
+
+  m = gfc_match (" %v =", &lvalue);
+  if (m != MATCH_YES)
+    gfc_current_locus = old_loc;
+  else
+    {
+      m = gfc_match (" %e )", &rvalue);
+      if (m == MATCH_YES)
+	{
+	  ns->code = gfc_get_code (EXEC_ASSIGN);
+	  ns->code->expr1 = lvalue;
+	  ns->code->expr2 = rvalue;
+	  ns->code->loc = old_loc;
+	  return true;
+	}
+
+      gfc_current_locus = old_loc;
+      gfc_free_expr (lvalue);
+    }
+
+  m = gfc_match (" %n", sname);
+  if (m != MATCH_YES)
+    return false;
+
+  if (strcmp (sname, omp_sym1->name) == 0
+      || strcmp (sname, omp_sym2->name) == 0)
+    return false;
+
+  gfc_current_ns = ns->parent;
+  if (gfc_get_ha_sym_tree (sname, &st))
+    return false;
+
+  sym = st->n.sym;
+  if (sym->attr.flavor != FL_PROCEDURE
+      && sym->attr.flavor != FL_UNKNOWN)
+    return false;
+
+  if (!sym->attr.generic
+      && !sym->attr.subroutine
+      && !sym->attr.function)
+    {
+      if (!(sym->attr.external && !sym->attr.referenced))
+	{
+	  /* ...create a symbol in this scope...  */
+	  if (sym->ns != gfc_current_ns
+	      && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
+	    return false;
+
+	  if (sym != st->n.sym)
+	    sym = st->n.sym;
+	}
+
+      /* ...and then to try to make the symbol into a subroutine.  */
+      if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
+	return false;
+    }
+
+  gfc_set_sym_referenced (sym);
+  gfc_gobble_whitespace ();
+  if (gfc_peek_ascii_char () != '(')
+    return false;
+
+  gfc_current_ns = ns;
+  m = gfc_match_actual_arglist (1, &arglist);
+  if (m != MATCH_YES)
+    return false;
+
+  if (gfc_match_char (')') != MATCH_YES)
+    return false;
+
+  ns->code = gfc_get_code (EXEC_CALL);
+  ns->code->symtree = st;
+  ns->code->ext.actual = arglist;
+  ns->code->loc = old_loc;
+  return true;
+}
+
+static bool
+gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
+		    gfc_typespec *ts, const char **n)
+{
+  if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
+    return false;
+
+  switch (rop)
+    {
+    case OMP_REDUCTION_PLUS:
+    case OMP_REDUCTION_MINUS:
+    case OMP_REDUCTION_TIMES:
+      return ts->type != BT_LOGICAL;
+    case OMP_REDUCTION_AND:
+    case OMP_REDUCTION_OR:
+    case OMP_REDUCTION_EQV:
+    case OMP_REDUCTION_NEQV:
+      return ts->type == BT_LOGICAL;
+    case OMP_REDUCTION_USER:
+      if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
+	{
+	  gfc_symbol *sym;
+
+	  gfc_find_symbol (name, NULL, 1, &sym);
+	  if (sym != NULL)
+	    {
+	      if (sym->attr.intrinsic)
+		*n = sym->name;
+	      else if ((sym->attr.flavor != FL_UNKNOWN
+			&& sym->attr.flavor != FL_PROCEDURE)
+		       || sym->attr.external
+		       || sym->attr.generic
+		       || sym->attr.entry
+		       || sym->attr.result
+		       || sym->attr.dummy
+		       || sym->attr.subroutine
+		       || sym->attr.pointer
+		       || sym->attr.target
+		       || sym->attr.cray_pointer
+		       || sym->attr.cray_pointee
+		       || (sym->attr.proc != PROC_UNKNOWN
+			   && sym->attr.proc != PROC_INTRINSIC)
+		       || sym->attr.if_source != IFSRC_UNKNOWN
+		       || sym == sym->ns->proc_name)
+		*n = NULL;
+	      else
+		*n = sym->name;
+	    }
+	  else
+	    *n = name;
+	  if (*n
+	      && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
+	    return true;
+	  else if (*n
+		   && ts->type == BT_INTEGER
+		   && (strcmp (*n, "iand") == 0
+		       || strcmp (*n, "ior") == 0
+		       || strcmp (*n, "ieor") == 0))
+	    return true;
+	}
+      break;
+    default:
+      break;
+    }
+  return false;
+}
+
+gfc_omp_udr *
+gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
+{
+  gfc_omp_udr *omp_udr;
+
+  if (st == NULL)
+    return NULL;
+
+  for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
+    if (omp_udr->ts.type == ts->type
+	|| ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
+	    && (ts->type == BT_DERIVED && ts->type == BT_CLASS)))
+      {
+	if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
+	  {
+	    if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
+	      return omp_udr;
+	  }
+	else if (omp_udr->ts.kind == ts->kind)
+	  {
+	    if (omp_udr->ts.type == BT_CHARACTER)
+	      {
+		if (omp_udr->ts.u.cl->length == NULL
+		    || ts->u.cl->length == NULL)
+		  return omp_udr;
+		if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+		  return omp_udr;
+		if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
+		  return omp_udr;
+		if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
+		  return omp_udr;
+		if (ts->u.cl->length->ts.type != BT_INTEGER)
+		  return omp_udr;
+		if (gfc_compare_expr (omp_udr->ts.u.cl->length,
+				      ts->u.cl->length, INTRINSIC_EQ) != 0)
+		  continue;
+	      }
+	    return omp_udr;
+	  }
+      }
+  return NULL;
+}
+
+match
+gfc_match_omp_declare_reduction (void)
+{
+  match m;
+  gfc_intrinsic_op op;
+  char name[GFC_MAX_SYMBOL_LEN + 3];
+  auto_vec<gfc_typespec, 5> tss;
+  gfc_typespec ts;
+  unsigned int i;
+  gfc_symtree *st;
+  locus where = gfc_current_locus;
+  locus end_loc = gfc_current_locus;
+  bool end_loc_set = false;
+  gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    return MATCH_ERROR;
+
+  m = gfc_match (" %o : ", &op);
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  if (m == MATCH_YES)
+    {
+      snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
+      rop = (gfc_omp_reduction_op) op;
+    }
+  else
+    {
+      m = gfc_match_defined_op_name (name + 1, 1);
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+      if (m == MATCH_YES)
+	{
+	  name[0] = '.';
+	  strcat (name, ".");
+	  if (gfc_match (" : ") != MATCH_YES)
+	    return MATCH_ERROR;
+	}
+      else
+	{
+	  if (gfc_match (" %n : ", name) != MATCH_YES)
+	    return MATCH_ERROR;
+	}
+      rop = OMP_REDUCTION_USER;
+    }
+
+  m = gfc_match_type_spec (&ts);
+  if (m != MATCH_YES)
+    return MATCH_ERROR;
+  tss.safe_push (ts);
+
+  while (gfc_match_char (',') == MATCH_YES)
+    {
+      m = gfc_match_type_spec (&ts);
+      if (m != MATCH_YES)
+	return MATCH_ERROR;
+      tss.safe_push (ts);
+    }
+  if (gfc_match_char (':') != MATCH_YES)
+    return MATCH_ERROR;
+
+  st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
+  for (i = 0; i < tss.length (); i++)
+    {
+      gfc_symtree *omp_out, *omp_in;
+      gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
+      gfc_namespace *combiner_ns, *initializer_ns = NULL;
+      gfc_omp_udr *prev_udr, *omp_udr;
+      const char *predef_name = NULL;
+
+      omp_udr = gfc_get_omp_udr ();
+      omp_udr->name = gfc_get_string (name);
+      omp_udr->rop = rop;
+      omp_udr->ts = tss[i];
+      omp_udr->where = where;
+
+      gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
+      combiner_ns->proc_name = combiner_ns->parent->proc_name;
+
+      gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
+      gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
+      combiner_ns->omp_udr_ns = 1;
+      omp_out->n.sym->ts = tss[i];
+      omp_in->n.sym->ts = tss[i];
+      omp_out->n.sym->attr.omp_udr_artificial_var = 1;
+      omp_in->n.sym->attr.omp_udr_artificial_var = 1;
+      gfc_commit_symbols ();
+      omp_udr->combiner_ns = combiner_ns;
+      omp_udr->omp_out = omp_out->n.sym;
+      omp_udr->omp_in = omp_in->n.sym;
+
+      locus old_loc = gfc_current_locus;
+
+      if (!match_udr_expr (omp_out, omp_in))
+	{
+	 syntax:
+	  gfc_current_locus = old_loc;
+	  gfc_current_ns = combiner_ns->parent;
+	  gfc_free_omp_udr (omp_udr);
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_match (" initializer ( ") == MATCH_YES)
+	{
+	  gfc_current_ns = combiner_ns->parent;
+	  initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
+	  gfc_current_ns = initializer_ns;
+	  initializer_ns->proc_name = initializer_ns->parent->proc_name;
+
+	  gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
+	  gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
+	  initializer_ns->omp_udr_ns = 1;
+	  omp_priv->n.sym->ts = tss[i];
+	  omp_orig->n.sym->ts = tss[i];
+	  omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
+	  omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
+	  gfc_commit_symbols ();
+	  omp_udr->initializer_ns = initializer_ns;
+	  omp_udr->omp_priv = omp_priv->n.sym;
+	  omp_udr->omp_orig = omp_orig->n.sym;
+
+	  if (!match_udr_expr (omp_priv, omp_orig))
+	    goto syntax;
+	}
+
+      gfc_current_ns = combiner_ns->parent;
+      if (!end_loc_set)
+	{
+	  end_loc_set = true;
+	  end_loc = gfc_current_locus;
+	}
+      gfc_current_locus = old_loc;
+
+      prev_udr = gfc_omp_udr_find (st, &tss[i]);
+      if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
+	  /* Don't error on !$omp declare reduction (min : integer : ...)
+	     just yet, there could be integer :: min afterwards,
+	     making it valid.  When the UDR is resolved, we'll get
+	     to it again.  */
+	  && (rop != OMP_REDUCTION_USER || name[0] == '.'))
+	{
+	  if (predef_name)
+	    gfc_error_now ("Redefinition of predefined %s "
+			   "!$OMP DECLARE REDUCTION at %L",
+			   predef_name, &where);
+	  else
+	    gfc_error_now ("Redefinition of predefined "
+			   "!$OMP DECLARE REDUCTION at %L", &where);
+	}
+      else if (prev_udr)
+	{
+	  gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
+			 &where);
+	  gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
+			 &prev_udr->where);
+	}
+      else if (st)
+	{
+	  omp_udr->next = st->n.omp_udr;
+	  st->n.omp_udr = omp_udr;
+	}
+      else
+	{
+	  st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
+	  st->n.omp_udr = omp_udr;
+	}
+    }
+
+  if (end_loc_set)
+    {
+      gfc_current_locus = end_loc;
+      return MATCH_YES;
+    }
+  gfc_clear_error ();
+  return MATCH_ERROR;
+}
+
+
 match
 gfc_match_omp_threadprivate (void)
 {
@@ -1285,10 +1750,8 @@ resolve_omp_clauses (gfc_code *code, loc
       {
 	const char *name;
 
-	if (list < OMP_LIST_REDUCTION_FIRST)
+	if (list < OMP_LIST_NUM)
 	  name = clause_names[list];
-	else if (list <= OMP_LIST_REDUCTION_LAST)
-	  name = clause_names[OMP_LIST_REDUCTION_FIRST];
 	else
 	  gcc_unreachable ();
 
@@ -1409,6 +1872,7 @@ resolve_omp_clauses (gfc_code *code, loc
 	  default:
 	    for (; n != NULL; n = n->next)
 	      {
+		bool bad = false;
 		if (n->sym->attr.threadprivate)
 		  gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
 			     n->sym->name, name, where);
@@ -1417,74 +1881,113 @@ resolve_omp_clauses (gfc_code *code, loc
 			    n->sym->name, name, where);
 		if (list != OMP_LIST_PRIVATE)
 		  {
-		    if (n->sym->attr.pointer
-			&& list >= OMP_LIST_REDUCTION_FIRST
-			&& list <= OMP_LIST_REDUCTION_LAST)
+		    if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
 		      gfc_error ("POINTER object '%s' in %s clause at %L",
 				 n->sym->name, name, where);
 		    /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below).  */
-		    if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST)
+		    if (list != OMP_LIST_REDUCTION
 			 && n->sym->ts.type == BT_DERIVED
 			 && n->sym->ts.u.derived->attr.alloc_comp)
 		      gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
 				 name, n->sym->name, where);
-		    if (n->sym->attr.cray_pointer
-			&& list >= OMP_LIST_REDUCTION_FIRST
-			&& list <= OMP_LIST_REDUCTION_LAST)
+		    if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
 		      gfc_error ("Cray pointer '%s' in %s clause at %L",
 				 n->sym->name, name, where);
 		  }
 		if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
 		  gfc_error ("Assumed size array '%s' in %s clause at %L",
 			     n->sym->name, name, where);
-		if (n->sym->attr.in_namelist
-		    && (list < OMP_LIST_REDUCTION_FIRST
-			|| list > OMP_LIST_REDUCTION_LAST))
+		if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
 		  gfc_error ("Variable '%s' in %s clause is used in "
 			     "NAMELIST statement at %L",
 			     n->sym->name, name, where);
 		switch (list)
 		  {
-		  case OMP_LIST_PLUS:
-		  case OMP_LIST_MULT:
-		  case OMP_LIST_SUB:
-		    if (!gfc_numeric_ts (&n->sym->ts))
-		      gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
-				 list == OMP_LIST_PLUS ? '+'
-				 : list == OMP_LIST_MULT ? '*' : '-',
-				 n->sym->name, where,
-				 gfc_typename (&n->sym->ts));
-		    break;
-		  case OMP_LIST_AND:
-		  case OMP_LIST_OR:
-		  case OMP_LIST_EQV:
-		  case OMP_LIST_NEQV:
-		    if (n->sym->ts.type != BT_LOGICAL)
-		      gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
-				 "at %L",
-				 list == OMP_LIST_AND ? ".AND."
-				 : list == OMP_LIST_OR ? ".OR."
-				 : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
-				 n->sym->name, where);
-		    break;
-		  case OMP_LIST_MAX:
-		  case OMP_LIST_MIN:
-		    if (n->sym->ts.type != BT_INTEGER
-			&& n->sym->ts.type != BT_REAL)
-		      gfc_error ("%s REDUCTION variable '%s' must be "
-				 "INTEGER or REAL at %L",
-				 list == OMP_LIST_MAX ? "MAX" : "MIN",
-				 n->sym->name, where);
-		    break;
-		  case OMP_LIST_IAND:
-		  case OMP_LIST_IOR:
-		  case OMP_LIST_IEOR:
-		    if (n->sym->ts.type != BT_INTEGER)
-		      gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
-				 "at %L",
-				 list == OMP_LIST_IAND ? "IAND"
-				 : list == OMP_LIST_MULT ? "IOR" : "IEOR",
-				 n->sym->name, where);
+		  case OMP_LIST_REDUCTION:
+		    switch (n->rop)
+		      {
+		      case OMP_REDUCTION_PLUS:
+		      case OMP_REDUCTION_TIMES:
+		      case OMP_REDUCTION_MINUS:
+			if (!gfc_numeric_ts (&n->sym->ts))
+			  bad = true;
+			break;
+		      case OMP_REDUCTION_AND:
+		      case OMP_REDUCTION_OR:
+		      case OMP_REDUCTION_EQV:
+		      case OMP_REDUCTION_NEQV:
+			if (n->sym->ts.type != BT_LOGICAL)
+			  bad = true;
+			break;
+		      case OMP_REDUCTION_MAX:
+		      case OMP_REDUCTION_MIN:
+			if (n->sym->ts.type != BT_INTEGER
+			    && n->sym->ts.type != BT_REAL)
+			  bad = true;
+			break;
+		      case OMP_REDUCTION_IAND:
+		      case OMP_REDUCTION_IOR:
+		      case OMP_REDUCTION_IEOR:
+			if (n->sym->ts.type != BT_INTEGER)
+			  bad = true;
+			break;
+		      case OMP_REDUCTION_USER:
+			bad = true;
+			break;
+		      default:
+			break;
+		      }
+		    if (!bad)
+		      n->udr = NULL;
+		    else
+		      {
+			const char *udr_name = NULL;
+			if (n->udr)
+			  {
+			    udr_name = n->udr->name;
+			    n->udr = gfc_find_omp_udr (NULL, udr_name,
+						       &n->sym->ts);
+			  }
+			if (n->udr == NULL)
+			  {
+			    if (udr_name == NULL)
+			      switch (n->rop)
+				{
+				case OMP_REDUCTION_PLUS:
+				case OMP_REDUCTION_TIMES:
+				case OMP_REDUCTION_MINUS:
+				case OMP_REDUCTION_AND:
+				case OMP_REDUCTION_OR:
+				case OMP_REDUCTION_EQV:
+				case OMP_REDUCTION_NEQV:
+				  udr_name = gfc_op2string ((gfc_intrinsic_op)
+							    n->rop);
+				  break;
+				case OMP_REDUCTION_MAX:
+				  udr_name = "max";
+				  break;
+				case OMP_REDUCTION_MIN:
+				  udr_name = "min";
+				  break;
+				case OMP_REDUCTION_IAND:
+				  udr_name = "iand";
+				  break;
+				case OMP_REDUCTION_IOR:
+				  udr_name = "ior";
+				  break;
+				case OMP_REDUCTION_IEOR:
+				  udr_name = "ieor";
+				  break;
+				default:
+				  gcc_unreachable ();
+				}
+			    gfc_error ("!$OMP DECLARE REDUCTION %s not found "
+				       "for type %s at %L", udr_name,
+				       gfc_typename (&n->sym->ts), where);
+			  }
+			else
+			  n->rop = OMP_REDUCTION_USER;
+		      }
 		    break;
 		  case OMP_LIST_LINEAR:
 		    if (n->sym->ts.type != BT_INTEGER)
@@ -2312,3 +2815,180 @@ gfc_resolve_omp_declare_simd (gfc_namesp
 	resolve_omp_clauses (NULL, &ods->where, ods->clauses, ns);
     }
 }
+
+struct omp_udr_callback_data
+{
+  gfc_omp_udr *omp_udr;
+  bool is_initializer;
+};
+
+static int
+omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+		  void *data)
+{
+  struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
+  if ((*e)->expr_type == EXPR_VARIABLE)
+    {
+      if (cd->is_initializer)
+	{
+	  if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
+	      && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
+	    gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
+		       "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
+		       &(*e)->where);
+	}
+      else
+	{
+	  if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
+	      && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
+	    gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
+		       "combiner of !$OMP DECLARE REDUCTION at %L",
+		       &(*e)->where);
+	}
+    }
+  else if ((*e)->expr_type == EXPR_FUNCTION
+	   && (*e)->value.function.isym == NULL)
+    {
+      gfc_symbol *sym = (*e)->symtree->n.sym;
+      if (!sym->attr.intrinsic
+	  && sym->attr.if_source == IFSRC_UNKNOWN)
+	gfc_error ("Implicitly declared function %s used in "
+		   "!$OMP DECLARE REDUCTION at %L ", sym->name, &(*e)->where);
+    }
+  return 0;
+}
+
+/* Resolve !$omp declare reduction constructs.  */
+
+static void
+gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
+{
+  gfc_actual_arglist *a;
+  const char *predef_name = NULL;
+
+  gfc_resolve (omp_udr->combiner_ns);
+  if (omp_udr->initializer_ns)
+    gfc_resolve (omp_udr->initializer_ns);
+  switch (omp_udr->rop)
+    {
+    case OMP_REDUCTION_PLUS:
+    case OMP_REDUCTION_TIMES:
+    case OMP_REDUCTION_MINUS:
+    case OMP_REDUCTION_AND:
+    case OMP_REDUCTION_OR:
+    case OMP_REDUCTION_EQV:
+    case OMP_REDUCTION_NEQV:
+    case OMP_REDUCTION_MAX:
+    case OMP_REDUCTION_USER:
+      break;
+    default:
+      gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
+		 omp_udr->name, &omp_udr->where);
+      return;
+    }
+
+  if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
+			  &omp_udr->ts, &predef_name))
+    {
+      if (predef_name)
+	gfc_error_now ("Redefinition of predefined %s "
+		       "!$OMP DECLARE REDUCTION at %L",
+		       predef_name, &omp_udr->where);
+      else
+	gfc_error_now ("Redefinition of predefined "
+		       "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
+      return;
+    }
+
+  if (omp_udr->ts.type == BT_CHARACTER
+      && omp_udr->ts.u.cl->length
+      && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+    {
+      gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
+		 "constant at %L", omp_udr->name, &omp_udr->where);
+      return;
+    }
+
+  struct omp_udr_callback_data cd;
+  cd.omp_udr = omp_udr;
+  cd.is_initializer = false;
+  gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
+		   omp_udr_callback, &cd);
+  if (omp_udr->combiner_ns->code->op == EXEC_CALL)
+    {
+      for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
+	if (a->expr == NULL)
+	  break;
+      if (a)
+	gfc_error ("Subroutine call with alternate returns in combiner "
+		   "of !$OMP DECLARE REDUCTION at %L",
+		   &omp_udr->combiner_ns->code->loc);
+      if (omp_udr->combiner_ns->code->resolved_isym == NULL)
+	{
+	  gfc_symbol *sym = omp_udr->combiner_ns->code->resolved_sym;
+	  if (sym
+	      && !sym->attr.intrinsic
+	      && sym->attr.if_source == IFSRC_UNKNOWN)
+	    gfc_error ("Implicitly declared subroutine %s used in "
+		       "!$OMP DECLARE REDUCTION at %L ", sym->name,
+		       &omp_udr->combiner_ns->code->loc);
+	}
+    }
+  if (omp_udr->initializer_ns)
+    {
+      cd.is_initializer = true;
+      gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
+		       omp_udr_callback, &cd);
+      if (omp_udr->initializer_ns->code->op == EXEC_CALL)
+	{
+	  for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
+	    if (a->expr == NULL)
+	      break;
+	  if (a)
+	    gfc_error ("Subroutine call with alternate returns in "
+		       "INITIALIZER clause of !$OMP DECLARE REDUCTION "
+		       "at %L", &omp_udr->initializer_ns->code->loc);
+	  for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
+	    if (a->expr
+		&& a->expr->expr_type == EXPR_VARIABLE
+		&& a->expr->symtree->n.sym == omp_udr->omp_priv
+		&& a->expr->ref == NULL)
+	      break;
+	  if (a == NULL)
+	    gfc_error ("One of actual subroutine arguments in INITIALIZER "
+		       "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
+		       "at %L", &omp_udr->initializer_ns->code->loc);
+	  if (omp_udr->initializer_ns->code->resolved_isym == NULL)
+	    {
+	      gfc_symbol *sym = omp_udr->initializer_ns->code->resolved_sym;
+	      if (sym
+		  && !sym->attr.intrinsic
+		  && sym->attr.if_source == IFSRC_UNKNOWN)
+		gfc_error ("Implicitly declared subroutine %s used in "
+			   "!$OMP DECLARE REDUCTION at %L ", sym->name,
+			   &omp_udr->initializer_ns->code->loc);
+	    }
+	}
+    }
+  else if (omp_udr->ts.type == BT_DERIVED
+	   && !gfc_has_default_initializer (omp_udr->ts.u.derived))
+    {
+      gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
+		 "of derived type without default initializer at %L",
+		 &omp_udr->where);
+      return;
+    }
+}
+
+void
+gfc_resolve_omp_udrs (gfc_symtree *st)
+{
+  gfc_omp_udr *omp_udr;
+
+  if (st == NULL)
+    return;
+  gfc_resolve_omp_udrs (st->left);
+  gfc_resolve_omp_udrs (st->right);
+  for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
+    gfc_resolve_omp_udr (omp_udr);
+}
--- gcc/fortran/parse.c.jj	2014-05-30 20:33:49.472060423 +0200
+++ gcc/fortran/parse.c	2014-06-02 10:36:19.744284805 +0200
@@ -575,6 +575,8 @@ decode_omp_directive (void)
       match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
       break;
     case 'd':
+      match ("declare reduction", gfc_match_omp_declare_reduction,
+	     ST_OMP_DECLARE_REDUCTION);
       match ("declare simd", gfc_match_omp_declare_simd,
 	     ST_OMP_DECLARE_SIMD);
       match ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
@@ -1050,7 +1052,7 @@ next_statement (void)
 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
   case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
   case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
-  case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD
+  case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION
 
 /* Block end statements.  Errors associated with interchanging these
    are detected in gfc_match_end().  */
@@ -1550,6 +1552,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_OMP_CRITICAL:
       p = "!$OMP CRITICAL";
       break;
+    case ST_OMP_DECLARE_REDUCTION:
+      p = "!$OMP DECLARE REDUCTION";
+      break;
     case ST_OMP_DECLARE_SIMD:
       p = "!$OMP DECLARE SIMD";
       break;
--- gcc/fortran/resolve.c.jj	2014-05-30 20:33:49.458060495 +0200
+++ gcc/fortran/resolve.c	2014-06-02 10:36:19.764284702 +0200
@@ -10866,7 +10866,10 @@ resolve_fl_variable (gfc_symbol *sym, in
     }
 
   /* Constraints on deferred type parameter.  */
-  if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
+  if (sym->ts.deferred
+      && !(sym->attr.pointer
+	   || sym->attr.allocatable
+	   || sym->attr.omp_udr_artificial_var))
     {
       gfc_error ("Entity '%s' at %L has a deferred type parameter and "
 		 "requires either the pointer or allocatable attribute",
@@ -10881,7 +10884,8 @@ resolve_fl_variable (gfc_symbol *sym, in
 	 dummy arguments.  */
       e = sym->ts.u.cl->length;
       if (e == NULL && !sym->attr.dummy && !sym->attr.result
-	  && !sym->ts.deferred && !sym->attr.select_type_temporary)
+	  && !sym->ts.deferred && !sym->attr.select_type_temporary
+	  && !sym->attr.omp_udr_artificial_var)
 	{
 	  gfc_error ("Entity with assumed character length at %L must be a "
 		     "dummy argument or a PARAMETER", &sym->declared_at);
@@ -14696,6 +14700,8 @@ resolve_types (gfc_namespace *ns)
 
   gfc_resolve_omp_declare_simd (ns);
 
+  gfc_resolve_omp_udrs (ns->omp_udr_root);
+
   gfc_current_ns = old_ns;
 }
 
--- gcc/fortran/symbol.c.jj	2014-05-30 20:33:49.491060325 +0200
+++ gcc/fortran/symbol.c	2014-06-02 10:36:19.774284650 +0200
@@ -2450,17 +2450,20 @@ gfc_get_uop (const char *name)
 {
   gfc_user_op *uop;
   gfc_symtree *st;
+  gfc_namespace *ns = gfc_current_ns;
 
-  st = gfc_find_symtree (gfc_current_ns->uop_root, name);
+  if (ns->omp_udr_ns)
+    ns = ns->parent;
+  st = gfc_find_symtree (ns->uop_root, name);
   if (st != NULL)
     return st->n.uop;
 
-  st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
+  st = gfc_new_symtree (&ns->uop_root, name);
 
   uop = st->n.uop = XCNEW (gfc_user_op);
   uop->name = gfc_get_string (name);
   uop->access = ACCESS_UNKNOWN;
-  uop->ns = gfc_current_ns;
+  uop->ns = ns;
 
   return uop;
 }
@@ -2771,6 +2774,12 @@ gfc_get_sym_tree (const char *name, gfc_
   /* Try to find the symbol in ns.  */
   st = gfc_find_symtree (ns->sym_root, name);
 
+  if (st == NULL && ns->omp_udr_ns)
+    {
+      ns = ns->parent;
+      st = gfc_find_symtree (ns->sym_root, name);
+    }
+
   if (st == NULL)
     {
       /* If not there, create a new symbol.  */
@@ -3269,6 +3278,23 @@ free_common_tree (gfc_symtree * common_t
 }  
 
 
+/* Recursive function that deletes an entire tree and all the common
+   head structures it points to.  */
+
+static void
+free_omp_udr_tree (gfc_symtree * omp_udr_tree)
+{
+  if (omp_udr_tree == NULL)
+    return;
+
+  free_omp_udr_tree (omp_udr_tree->left);
+  free_omp_udr_tree (omp_udr_tree->right);
+
+  gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
+  free (omp_udr_tree);
+}
+
+
 /* Recursive function that deletes an entire tree and all the user
    operator nodes that it contains.  */
 
@@ -3465,6 +3491,7 @@ gfc_free_namespace (gfc_namespace *ns)
   free_sym_tree (ns->sym_root);
   free_uop_tree (ns->uop_root);
   free_common_tree (ns->common_root);
+  free_omp_udr_tree (ns->omp_udr_root);
   free_tb_tree (ns->tb_sym_root);
   free_tb_tree (ns->tb_uop_root);
   gfc_free_finalizer_list (ns->finalizers);
--- gcc/fortran/trans-openmp.c.jj	2014-05-30 20:33:49.416060708 +0200
+++ gcc/fortran/trans-openmp.c	2014-06-02 10:36:19.786284587 +0200
@@ -525,12 +525,104 @@ gfc_trans_omp_variable_list (enum omp_cl
   return list;
 }
 
+struct omp_udr_find_orig_data
+{
+  gfc_omp_udr *omp_udr;
+  bool omp_orig_seen;
+};
+
+static int
+omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+		   void *data)
+{
+  struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data;
+  if ((*e)->expr_type == EXPR_VARIABLE
+      && (*e)->symtree->n.sym == cd->omp_udr->omp_orig)
+    cd->omp_orig_seen = true;
+
+  return 0;
+}
+
+static tree
+gfc_trans_omp_udr_expr (gfc_omp_namelist *n, bool is_initializer,
+			gfc_expr *syme, gfc_expr *outere)
+{
+  gfc_se symse, outerse;
+  gfc_ss *symss, *outerss;
+  gfc_loopinfo loop;
+  stmtblock_t block, body;
+  tree tem;
+  int i;
+  gfc_namespace *ns = (is_initializer
+		       ? n->udr->initializer_ns : n->udr->combiner_ns);
+
+  syme = gfc_copy_expr (syme);
+  outere = gfc_copy_expr (outere);
+  gfc_init_se (&symse, NULL);
+  gfc_init_se (&outerse, NULL);
+  gfc_start_block (&block);
+  gfc_init_loopinfo (&loop);
+  symss = gfc_walk_expr (syme);
+  outerss = gfc_walk_expr (outere);
+  gfc_add_ss_to_loop (&loop, symss);
+  gfc_add_ss_to_loop (&loop, outerss);
+  gfc_conv_ss_startstride (&loop);
+  /* Enable loop reversal.  */
+  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+    loop.reverse[i] = GFC_ENABLE_REVERSE;
+  gfc_conv_loop_setup (&loop, &ns->code->loc);
+  gfc_copy_loopinfo_to_se (&symse, &loop);
+  gfc_copy_loopinfo_to_se (&outerse, &loop);
+  symse.ss = symss;
+  outerse.ss = outerss;
+  gfc_mark_ss_chain_used (symss, 1);
+  gfc_mark_ss_chain_used (outerss, 1);
+  gfc_start_scalarized_body (&loop, &body);
+  gfc_conv_expr (&symse, syme);
+  gfc_conv_expr (&outerse, outere);
+
+  if (is_initializer)
+    {
+      n->udr->omp_priv->backend_decl = symse.expr;
+      n->udr->omp_orig->backend_decl = outerse.expr;
+    }
+  else
+    {
+      n->udr->omp_out->backend_decl = outerse.expr;
+      n->udr->omp_in->backend_decl = symse.expr;
+    }
+
+  if (ns->code->op == EXEC_ASSIGN)
+    tem = gfc_trans_assignment (ns->code->expr1, ns->code->expr2,
+				false, false);
+  else
+    tem = gfc_trans_call (ns->code, false, NULL_TREE, NULL_TREE, false);
+  gfc_add_expr_to_block (&body, tem);
+
+  gcc_assert (symse.ss == gfc_ss_terminator
+	      && outerse.ss == gfc_ss_terminator);
+  /* Generate the copying loops.  */
+  gfc_trans_scalarizing_loops (&loop, &body);
+
+  /* Wrap the whole thing up.  */
+  gfc_add_block_to_block (&block, &loop.pre);
+  gfc_add_block_to_block (&block, &loop.post);
+
+  gfc_cleanup_loop (&loop);
+  gfc_free_expr (syme);
+  gfc_free_expr (outere);
+
+  return gfc_finish_block (&block);
+}
+
 static void
-gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
+gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
 {
+  gfc_symbol *sym = n->sym;
   gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
   gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
   gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
+  gfc_symbol omp_var_copy[4];
   gfc_expr *e1, *e2, *e3, *e4;
   gfc_ref *ref;
   tree decl, backend_decl, stmt, type, outer_decl;
@@ -559,12 +651,29 @@ gfc_trans_omp_array_reduction (tree c, g
   init_val_sym.attr.referenced = 1;
   init_val_sym.declared_at = where;
   init_val_sym.attr.flavor = FL_VARIABLE;
-  backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
+  if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
+    backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
+  else if (n->udr->initializer_ns)
+    backend_decl = NULL;
+  else
+    switch (sym->ts.type)
+      {
+      case BT_LOGICAL:
+      case BT_INTEGER:
+      case BT_REAL:
+      case BT_COMPLEX:
+	backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym));
+	break;
+      default:
+	backend_decl = NULL_TREE;
+	break;
+      }
   init_val_sym.backend_decl = backend_decl;
 
   /* Create a fake symbol for the outer array reference.  */
   outer_sym = *sym;
-  outer_sym.as = gfc_copy_array_spec (sym->as);
+  if (sym->as)
+    outer_sym.as = gfc_copy_array_spec (sym->as);
   outer_sym.attr.dummy = 0;
   outer_sym.attr.result = 0;
   outer_sym.attr.flavor = FL_VARIABLE;
@@ -585,28 +694,94 @@ gfc_trans_omp_array_reduction (tree c, g
   symtree3->n.sym = &outer_sym;
   gcc_assert (symtree3 == root3);
 
+  memset (omp_var_copy, 0, sizeof omp_var_copy);
+  if (n->udr)
+    {
+      omp_var_copy[0] = *n->udr->omp_out;
+      omp_var_copy[1] = *n->udr->omp_in;
+      if (sym->attr.dimension)
+	{
+	  n->udr->omp_out->ts = sym->ts;
+	  n->udr->omp_in->ts = sym->ts;
+	}
+      else
+	{
+	  *n->udr->omp_out = outer_sym;
+	  *n->udr->omp_in = *sym;
+	}
+      if (n->udr->initializer_ns)
+	{
+	  omp_var_copy[2] = *n->udr->omp_priv;
+	  omp_var_copy[3] = *n->udr->omp_orig;
+	  if (sym->attr.dimension)
+	    {
+	      n->udr->omp_priv->ts = sym->ts;
+	      n->udr->omp_orig->ts = sym->ts;
+	    }
+	  else
+	    {
+	      *n->udr->omp_priv = *sym;
+	      *n->udr->omp_orig = outer_sym;
+	    }
+	}
+    }
+
   /* Create expressions.  */
   e1 = gfc_get_expr ();
   e1->expr_type = EXPR_VARIABLE;
   e1->where = where;
   e1->symtree = symtree1;
   e1->ts = sym->ts;
-  e1->ref = ref = gfc_get_ref ();
-  ref->type = REF_ARRAY;
-  ref->u.ar.where = where;
-  ref->u.ar.as = sym->as;
-  ref->u.ar.type = AR_FULL;
-  ref->u.ar.dimen = 0;
+  if (sym->attr.dimension)
+    {
+      e1->ref = ref = gfc_get_ref ();
+      ref->type = REF_ARRAY;
+      ref->u.ar.where = where;
+      ref->u.ar.as = sym->as;
+      ref->u.ar.type = AR_FULL;
+      ref->u.ar.dimen = 0;
+    }
   t = gfc_resolve_expr (e1);
   gcc_assert (t);
 
-  e2 = gfc_get_expr ();
-  e2->expr_type = EXPR_VARIABLE;
-  e2->where = where;
-  e2->symtree = symtree2;
-  e2->ts = sym->ts;
-  t = gfc_resolve_expr (e2);
-  gcc_assert (t);
+  e2 = NULL;
+  if (backend_decl != NULL_TREE)
+    {
+      e2 = gfc_get_expr ();
+      e2->expr_type = EXPR_VARIABLE;
+      e2->where = where;
+      e2->symtree = symtree2;
+      e2->ts = sym->ts;
+      t = gfc_resolve_expr (e2);
+      gcc_assert (t);
+    }
+  else if (n->udr->initializer_ns == NULL)
+    {
+      gcc_assert (sym->ts.type == BT_DERIVED);
+      e2 = gfc_default_initializer (&sym->ts);
+      gcc_assert (e2);
+      t = gfc_resolve_expr (e2);
+      gcc_assert (t);
+    }
+  else if (n->udr->initializer_ns->code->op == EXEC_ASSIGN)
+    {
+      if (!sym->attr.dimension)
+	{
+	  e2 = gfc_copy_expr (n->udr->initializer_ns->code->expr2);
+	  t = gfc_resolve_expr (e2);
+	  gcc_assert (t);
+	}
+    }
+  if (n->udr && n->udr->initializer_ns)
+    {
+      struct omp_udr_find_orig_data cd;
+      cd.omp_udr = n->udr;
+      cd.omp_orig_seen = false;
+      gfc_code_walker (&n->udr->initializer_ns->code,
+		       gfc_dummy_code_callback, omp_udr_find_orig, &cd);
+      if (cd.omp_orig_seen)
+	OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1;
+    }
 
   e3 = gfc_copy_expr (e1);
   e3->symtree = symtree3;
@@ -614,6 +789,7 @@ gfc_trans_omp_array_reduction (tree c, g
   gcc_assert (t);
 
   iname = NULL;
+  e4 = NULL;
   switch (OMP_CLAUSE_REDUCTION_CODE (c))
     {
     case PLUS_EXPR:
@@ -650,6 +826,21 @@ gfc_trans_omp_array_reduction (tree c, g
     case BIT_XOR_EXPR:
       iname = "ieor";
       break;
+    case ERROR_MARK:
+      if (n->udr->combiner_ns->code->op == EXEC_ASSIGN)
+	{
+	  if (!sym->attr.dimension)
+	    {
+	      gfc_free_expr (e3);
+	      e3 = gfc_copy_expr (n->udr->combiner_ns->code->expr1);
+	      e4 = gfc_copy_expr (n->udr->combiner_ns->code->expr2);
+	      t = gfc_resolve_expr (e3);
+	      gcc_assert (t);
+	      t = gfc_resolve_expr (e4);
+	      gcc_assert (t);
+	    }
+	}
+      break;
     default:
       gcc_unreachable ();
     }
@@ -679,15 +870,19 @@ gfc_trans_omp_array_reduction (tree c, g
       e4->value.function.actual->next = gfc_get_actual_arglist ();
       e4->value.function.actual->next->expr = e1;
     }
-  /* e1 and e3 have been stored as arguments of e4, avoid sharing.  */
-  e1 = gfc_copy_expr (e1);
-  e3 = gfc_copy_expr (e3);
-  t = gfc_resolve_expr (e4);
-  gcc_assert (t);
+  if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
+    {
+      /* e1 and e3 have been stored as arguments of e4, avoid sharing.  */
+      e1 = gfc_copy_expr (e1);
+      e3 = gfc_copy_expr (e3);
+      t = gfc_resolve_expr (e4);
+      gcc_assert (t);
+    }
 
   /* Create the init statement list.  */
   pushlevel ();
-  if (GFC_DESCRIPTOR_TYPE_P (type)
+  if (sym->attr.dimension
+      && GFC_DESCRIPTOR_TYPE_P (type)
       && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
     {
       /* If decl is an allocatable array, it needs to be allocated
@@ -719,12 +914,20 @@ gfc_trans_omp_array_reduction (tree c, g
       gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
       gfc_conv_descriptor_data_set (&block, decl, ptr);
 
-      gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
-			     false));
+      if (e2)
+	stmt = gfc_trans_assignment (e1, e2, false, false);
+      else
+	stmt = gfc_trans_omp_udr_expr (n, true, e1, e3);
+      gfc_add_expr_to_block (&block, stmt);
       stmt = gfc_finish_block (&block);
     }
-  else
+  else if (e2)
     stmt = gfc_trans_assignment (e1, e2, false, false);
+  else if (sym->attr.dimension)
+    stmt = gfc_trans_omp_udr_expr (n, true, e1, e3);
+  else
+    stmt = gfc_trans_call (n->udr->initializer_ns->code, false,
+			   NULL_TREE, NULL_TREE, false);
   if (TREE_CODE (stmt) != BIND_EXPR)
     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
   else
@@ -733,7 +936,8 @@ gfc_trans_omp_array_reduction (tree c, g
 
   /* Create the merge statement list.  */
   pushlevel ();
-  if (GFC_DESCRIPTOR_TYPE_P (type)
+  if (sym->attr.dimension
+      && GFC_DESCRIPTOR_TYPE_P (type)
       && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
     {
       /* If decl is an allocatable array, it needs to be deallocated
@@ -741,14 +945,22 @@ gfc_trans_omp_array_reduction (tree c, g
       stmtblock_t block;
 
       gfc_start_block (&block);
-      gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
-			     true));
+      if (e4)
+	stmt = gfc_trans_assignment (e3, e4, false, true);
+      else
+	stmt = gfc_trans_omp_udr_expr (n, false, e1, e3);
+      gfc_add_expr_to_block (&block, stmt);
       gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false,
 								  NULL));
       stmt = gfc_finish_block (&block);
     }
-  else
+  else if (e4)
     stmt = gfc_trans_assignment (e3, e4, false, true);
+  else if (sym->attr.dimension)
+    stmt = gfc_trans_omp_udr_expr (n, false, e1, e3);
+  else
+    stmt = gfc_trans_call (n->udr->combiner_ns->code, false,
+			   NULL_TREE, NULL_TREE, false);
   if (TREE_CODE (stmt) != BIND_EXPR)
     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
   else
@@ -761,19 +973,33 @@ gfc_trans_omp_array_reduction (tree c, g
   gfc_current_locus = old_loc;
 
   gfc_free_expr (e1);
-  gfc_free_expr (e2);
+  if (e2)
+    gfc_free_expr (e2);
   gfc_free_expr (e3);
-  gfc_free_expr (e4);
+  if (e4)
+    gfc_free_expr (e4);
   free (symtree1);
   free (symtree2);
   free (symtree3);
   free (symtree4);
-  gfc_free_array_spec (outer_sym.as);
+  if (outer_sym.as)
+    gfc_free_array_spec (outer_sym.as);
+
+  if (n->udr)
+    {
+      *n->udr->omp_out = omp_var_copy[0];
+      *n->udr->omp_in = omp_var_copy[1];
+      if (n->udr->initializer_ns)
+	{
+	  *n->udr->omp_priv = omp_var_copy[2];
+	  *n->udr->omp_orig = omp_var_copy[3];
+	}
+    }
 }
 
 static tree
 gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list,
-			      enum tree_code reduction_code, locus where)
+			      locus where)
 {
   for (; namelist != NULL; namelist = namelist->next)
     if (namelist->sym->attr.referenced)
@@ -784,9 +1010,53 @@ gfc_trans_omp_reduction_list (gfc_omp_na
 	    tree node = build_omp_clause (where.lb->location,
 					  OMP_CLAUSE_REDUCTION);
 	    OMP_CLAUSE_DECL (node) = t;
-	    OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
-	    if (namelist->sym->attr.dimension)
-	      gfc_trans_omp_array_reduction (node, namelist->sym, where);
+	    switch (namelist->rop)
+	      {
+	      case OMP_REDUCTION_PLUS:
+		OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR;
+		break;
+	      case OMP_REDUCTION_MINUS:
+		OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR;
+		break;
+	      case OMP_REDUCTION_TIMES:
+		OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR;
+		break;
+	      case OMP_REDUCTION_AND:
+		OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR;
+		break;
+	      case OMP_REDUCTION_OR:
+		OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR;
+		break;
+	      case OMP_REDUCTION_EQV:
+		OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR;
+		break;
+	      case OMP_REDUCTION_NEQV:
+		OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR;
+		break;
+	      case OMP_REDUCTION_MAX:
+		OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR;
+		break;
+	      case OMP_REDUCTION_MIN:
+		OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR;
+		break;
+ 	      case OMP_REDUCTION_IAND:
+		OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR;
+		break;
+ 	      case OMP_REDUCTION_IOR:
+		OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR;
+		break;
+ 	      case OMP_REDUCTION_IEOR:
+		OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR;
+		break;
+	      case OMP_REDUCTION_USER:
+		OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK;
+		break;
+	      default:
+		gcc_unreachable ();
+	      }
+	    if (namelist->sym->attr.dimension
+		|| namelist->rop == OMP_REDUCTION_USER)
+	      gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
 	    list = gfc_trans_add_clause (node, list);
 	  }
       }
@@ -811,58 +1081,11 @@ gfc_trans_omp_clauses (stmtblock_t *bloc
 
       if (n == NULL)
 	continue;
-      if (list >= OMP_LIST_REDUCTION_FIRST
-	  && list <= OMP_LIST_REDUCTION_LAST)
-	{
-	  enum tree_code reduction_code;
-	  switch (list)
-	    {
-	    case OMP_LIST_PLUS:
-	      reduction_code = PLUS_EXPR;
-	      break;
-	    case OMP_LIST_MULT:
-	      reduction_code = MULT_EXPR;
-	      break;
-	    case OMP_LIST_SUB:
-	      reduction_code = MINUS_EXPR;
-	      break;
-	    case OMP_LIST_AND:
-	      reduction_code = TRUTH_ANDIF_EXPR;
-	      break;
-	    case OMP_LIST_OR:
-	      reduction_code = TRUTH_ORIF_EXPR;
-	      break;
-	    case OMP_LIST_EQV:
-	      reduction_code = EQ_EXPR;
-	      break;
-	    case OMP_LIST_NEQV:
-	      reduction_code = NE_EXPR;
-	      break;
-	    case OMP_LIST_MAX:
-	      reduction_code = MAX_EXPR;
-	      break;
-	    case OMP_LIST_MIN:
-	      reduction_code = MIN_EXPR;
-	      break;
-	    case OMP_LIST_IAND:
-	      reduction_code = BIT_AND_EXPR;
-	      break;
-	    case OMP_LIST_IOR:
-	      reduction_code = BIT_IOR_EXPR;
-	      break;
-	    case OMP_LIST_IEOR:
-	      reduction_code = BIT_XOR_EXPR;
-	      break;
-	    default:
-	      gcc_unreachable ();
-	    }
-	  omp_clauses
-	    = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
-					    where);
-	  continue;
-	}
       switch (list)
 	{
+	case OMP_LIST_REDUCTION:
+	  omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, where);
+	  break;
 	case OMP_LIST_PRIVATE:
 	  clause_code = OMP_CLAUSE_PRIVATE;
 	  goto add_clause;
@@ -1923,7 +2146,7 @@ static void
 gfc_split_omp_clauses (gfc_code *code,
 		       gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
 {
-  int mask = 0, innermost = 0, i;
+  int mask = 0, innermost = 0;
   memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
   switch (code->op)
     {
@@ -2021,18 +2244,15 @@ gfc_split_omp_clauses (gfc_code *code,
       /* Reduction is allowed on simd, do, parallel and teams.
 	 Duplicate it on all of them, but omit on do if
 	 parallel is present.  */
-      for (i = OMP_LIST_REDUCTION_FIRST; i <= OMP_LIST_REDUCTION_LAST; i++)
-	{
-	  if (mask & GFC_OMP_MASK_PARALLEL)
-	    clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i]
-	      = code->ext.omp_clauses->lists[i];
-	  else if (mask & GFC_OMP_MASK_DO)
-	    clausesa[GFC_OMP_SPLIT_DO].lists[i]
-	      = code->ext.omp_clauses->lists[i];
-	  if (mask & GFC_OMP_MASK_SIMD)
-	    clausesa[GFC_OMP_SPLIT_SIMD].lists[i]
-	      = code->ext.omp_clauses->lists[i];
-	}
+      if (mask & GFC_OMP_MASK_PARALLEL)
+	clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_REDUCTION]
+	  = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
+      else if (mask & GFC_OMP_MASK_DO)
+	clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_REDUCTION]
+	  = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
+      if (mask & GFC_OMP_MASK_SIMD)
+	clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_REDUCTION]
+	  = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
     }
   if ((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
       == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
--- gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90.jj	2014-05-30 20:33:49.692059296 +0200
+++ gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90	2014-06-02 10:36:19.823284396 +0200
@@ -49,7 +49,7 @@ CONTAINS
     TYPE(t) :: a(10)
     INTEGER :: i
 
-    !$omp parallel do reduction(+: a)   ! { dg-error "must be of numeric type" }
+    !$omp parallel do reduction(+: a)   ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
     DO i = 1, SIZE(a)
     END DO
     !$omp end parallel do
--- gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.3.f90.jj	2014-05-30 20:33:49.685059331 +0200
+++ gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.3.f90	2014-06-02 10:36:19.827284374 +0200
@@ -5,7 +5,7 @@
         !$OMP PARALLEL DO REDUCTION(MAX: M) ! MAX is no longer the
                                             ! intrinsic so this
                                             ! is non-conforming
-! { dg-error "is not INTRINSIC procedure name" "" { target *-*-* } 5 } */
+! { dg-error "OMP DECLARE REDUCTION max not found" "" { target *-*-* } 5 } */
         DO I = 1, 100
         CALL SUB(M,I)
         END DO
--- gcc/testsuite/gfortran.dg/gomp/reduction1.f90.jj	2014-05-30 20:33:49.692059296 +0200
+++ gcc/testsuite/gfortran.dg/gomp/reduction1.f90	2014-06-02 10:36:19.827284374 +0200
@@ -60,73 +60,73 @@ common /blk/ i1
 !$omp end parallel
 !$omp parallel reduction (*:ia1)	! { dg-error "Assumed size" }
 !$omp end parallel
-!$omp parallel reduction (+:l1)		! { dg-error "must be of numeric type, got LOGICAL" }
+!$omp parallel reduction (+:l1)		! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (*:la1)	! { dg-error "must be of numeric type, got LOGICAL" }
+!$omp parallel reduction (*:la1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (-:a1)		! { dg-error "must be of numeric type, got CHARACTER" }
+!$omp parallel reduction (-:a1)		! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (+:t1)		! { dg-error "must be of numeric type, got TYPE" }
+!$omp parallel reduction (+:t1)		! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (*:ta1)	! { dg-error "must be of numeric type, got TYPE" }
+!$omp parallel reduction (*:ta1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (.and.:i3)	! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.and.:i3)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (.or.:ia2)	! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.or.:ia2)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (.eqv.:r1)	! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.eqv.:r1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (.neqv.:ra1)	! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.neqv.:ra1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (.and.:d1)	! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.and.:d1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (.or.:da1)	! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.or.:da1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (.eqv.:c1)	! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.eqv.:c1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (.neqv.:ca1)	! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.neqv.:ca1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (.and.:a1)	! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.and.:a1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (.or.:t1)	! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.or.:t1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (.eqv.:ta1)	! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.eqv.:ta1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (min:c1)	! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (min:c1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (max:ca1)	! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (max:ca1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (max:l1)	! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (max:l1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (min:la1)	! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (min:la1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (max:a1)	! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (max:a1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (min:t1)	! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (min:t1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (max:ta1)	! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (max:ta1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (iand:r1)	! { dg-error "must be INTEGER" }
+!$omp parallel reduction (iand:r1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (ior:ra1)	! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ior:ra1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (ieor:d1)	! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ieor:d1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (ior:da1)	! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ior:da1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (iand:c1)	! { dg-error "must be INTEGER" }
+!$omp parallel reduction (iand:c1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (ior:ca1)	! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ior:ca1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (ieor:l1)	! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ieor:l1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (iand:la1)	! { dg-error "must be INTEGER" }
+!$omp parallel reduction (iand:la1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (ior:a1)	! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ior:a1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (ieor:t1)	! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ieor:t1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
-!$omp parallel reduction (iand:ta1)	! { dg-error "must be INTEGER" }
+!$omp parallel reduction (iand:ta1)	! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
 !$omp end parallel
 
 end subroutine
--- gcc/testsuite/gfortran.dg/gomp/reduction3.f90.jj	2014-05-30 20:33:49.692059296 +0200
+++ gcc/testsuite/gfortran.dg/gomp/reduction3.f90	2014-06-02 10:36:19.828284369 +0200
@@ -16,7 +16,7 @@ subroutine f1
   integer :: i, ior
   ior = 6
   i = 6
-!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
+!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
 !$omp end parallel
 end subroutine f1
 subroutine f2
@@ -27,7 +27,7 @@ subroutine f2
     end function
   end interface
   i = 6
-!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
+!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
   i = ior (i, 3)
 !$omp end parallel
 end subroutine f2
@@ -50,7 +50,7 @@ subroutine f5
   use mreduction3
   integer :: i
   i = 6
-!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
+!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
   i = ior (i, 7)
 !$omp end parallel
 end subroutine f5
@@ -58,7 +58,7 @@ subroutine f6
   use mreduction3
   integer :: i
   i = 6
-!$omp parallel reduction (iand:i) ! { dg-error "is not INTRINSIC procedure name" }
+!$omp parallel reduction (iand:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
   i = iand (i, 18)
 !$omp end parallel
 end subroutine f6
--- gcc/testsuite/gfortran.dg/gomp/udr1.f90.jj	2014-06-02 10:36:19.828284369 +0200
+++ gcc/testsuite/gfortran.dg/gomp/udr1.f90	2014-06-02 10:36:19.828284369 +0200
@@ -0,0 +1,41 @@
+! { dg-do compile }
+
+subroutine f1
+!$omp declare reduction (.le.:integer:omp_out = omp_out + omp_in) ! { dg-error "Invalid operator for" }
+end subroutine f1
+subroutine f2
+!$omp declare reduction (bar:real(kind=4):omp_out = omp_out + omp_in)
+  real(kind=4) :: r
+  integer :: i
+  r = 0.0
+!$omp parallel do reduction (bar:r)
+  do i = 1, 10
+    r = r + i
+  end do
+!$omp parallel do reduction (foo:r) ! { dg-error "foo not found" }
+  do i = 1, 10
+    r = r + i
+  end do
+!$omp parallel do reduction (.gt.:r) ! { dg-error "cannot be used as a defined operator" }
+  do i = 1, 10
+    r = r + i
+  end do
+end subroutine f2
+subroutine f3
+!$omp declare reduction (foo:blah:omp_out=omp_out + omp_in) ! { dg-error "Unclassifiable OpenMP directive" }
+end subroutine f3
+subroutine f4
+!$omp declare reduction (foo:integer:a => null()) ! { dg-error "Invalid character in name" }
+!$omp declare reduction (foo:integer:omp_out = omp_in + omp_out) &
+!$omp & initializer(a => null()) ! { dg-error "Invalid character in name" }
+end subroutine f4
+subroutine f5
+  integer :: a, b
+!$omp declare reduction (foo:integer:a = b + 1) ! { dg-error "Variable other than OMP_OUT or OMP_IN used in combiner" }
+!$omp declare reduction (bar:integer:omp_out = omp_out * omp_in) &
+!$omp & initializer(b = a + 1) ! { dg-error "Variable other than OMP_PRIV or OMP_ORIG used in INITIALIZER clause" }
+end subroutine f5
+subroutine f6
+!$omp declare reduction (foo:integer:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_orig=omp_priv)
+end subroutine f6
--- gcc/testsuite/gfortran.dg/gomp/udr2.f90.jj	2014-06-02 10:36:19.828284369 +0200
+++ gcc/testsuite/gfortran.dg/gomp/udr2.f90	2014-06-02 10:36:19.828284369 +0200
@@ -0,0 +1,43 @@
+! { dg-do compile }
+
+subroutine f6
+!$omp declare reduction (foo:real:omp_out (omp_in)) ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction (bar:real:omp_out = omp_in * omp_out) & ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp & initializer (omp_priv (omp_orig))
+end subroutine f6
+subroutine f7
+  integer :: a
+!$omp declare reduction (foo:integer:a (omp_out, omp_in)) ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction (bar:real:omp_out = omp_out.or.omp_in) ! { dg-error "Operands of logical operator" }
+!$omp declare reduction (baz:real:omp_out = omp_out + omp_in)
+!$omp & initializer (a (omp_priv, omp_orig)) ! { dg-error "Unclassifiable OpenMP directive" }
+end subroutine f7
+subroutine f8
+  interface
+    subroutine f8a (x)
+      integer :: x
+    end subroutine f8a
+  end interface
+!$omp declare reduction (baz:integer:omp_out = omp_out + omp_in) &
+!$omp & initializer (f8a (omp_orig)) ! { dg-error "One of actual subroutine arguments in INITIALIZER clause" }
+!$omp declare reduction (foo:integer:f8a) ! { dg-error "is not a variable" }
+!$omp declare reduction (bar:integer:omp_out = omp_out - omp_in) &
+!$omp & initializer (f8a) ! { dg-error "is not a variable" }
+end subroutine f8
+subroutine f9
+  type dt	! { dg-error "which is not consistent with the CALL" }
+    integer :: x = 0
+    integer :: y = 0
+  end type dt
+!$omp declare reduction (foo:integer:dt (omp_out, omp_in)) ! { dg-error "which is not consistent with the CALL" }
+!$omp declare reduction (bar:integer:omp_out = omp_out + omp_in) &
+!$omp & initializer (dt (omp_priv, omp_orig)) ! { dg-error "which is not consistent with the CALL" }
+end subroutine f9
+subroutine f10
+  integer :: a, b
+!$omp declare reduction(foo:character(len=64) &
+!$omp & :omp_out(a:b) = omp_in(a:b)) ! { dg-error "Variable other than OMP_OUT or OMP_IN used in combiner" }
+!$omp declare reduction(bar:character(len=16) &
+!$omp & :omp_out = trim(omp_out) // omp_in) &
+!$omp & initializer (omp_priv(a:b) = ' ') ! { dg-error "Variable other than OMP_PRIV or OMP_ORIG used in INITIALIZER clause" }
+end subroutine f10
--- gcc/testsuite/gfortran.dg/gomp/udr3.f90.jj	2014-06-02 10:36:19.829284364 +0200
+++ gcc/testsuite/gfortran.dg/gomp/udr3.f90	2014-06-02 14:37:59.818184325 +0200
@@ -0,0 +1,75 @@
+! { dg-do compile }
+
+subroutine f1
+  type dt
+    logical :: l = .false.
+  end type
+  type dt2
+    logical :: l = .false.
+  end type
+!$omp declare reduction (foo:integer(kind = 4) & ! { dg-error "Previous !.OMP DECLARE REDUCTION" }
+!$omp & :omp_out = omp_out + omp_in)
+!$omp declare reduction (foo:integer(kind = 4) : & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" }
+!$omp & omp_out = omp_out + omp_in)
+!$omp declare reduction (bar:integer, &
+!$omp & real:omp_out = omp_out + omp_in)
+!$omp declare reduction (baz:integer,real,integer & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" }
+!$omp & : omp_out = omp_out + omp_in)
+!$omp declare reduction (id1:dt,dt2:omp_out%l=omp_out%l &
+!$omp & .or.omp_in%l)
+!$omp declare reduction (id2:dt,dt:omp_out%l=omp_out%l & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" }
+!$omp & .or.omp_in%l)
+!$omp declare reduction (id3:dt2,dt:omp_out%l=omp_out%l & ! { dg-error "Previous !.OMP DECLARE REDUCTION" }
+!$omp & .or.omp_in%l)
+!$omp declare reduction (id3:dt2:omp_out%l=omp_out%l & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" }
+!$omp & .or.omp_in%l)
+end subroutine f1
+subroutine f2
+  interface
+    subroutine f2a (x, y, z)
+      character (len = *) :: x, y
+      logical :: z
+    end subroutine
+  end interface
+  interface f2b
+    subroutine f2b (x, y, z)
+      character (len = *, kind = 1) :: x, y
+      logical :: z
+    end subroutine
+    subroutine f2c (x, y, z)
+      character (kind = 4, len = *) :: x, y
+      logical :: z
+    end subroutine
+  end interface
+!$omp declare reduction (foo:character(len=*): &
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (bar:character(len=:): &
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (baz:character(len=4): &
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (baz:character(len=5): &
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (baz:character(len=6): &
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (id:character(len=*): & ! { dg-error "Previous !.OMP DECLARE REDUCTION" }
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (id: & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" }
+!$omp & character(len=:) : f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" }
+!$omp (id2:character(len=*), character(len=:): &
+!$omp f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (id3:character(len=*, kind = 1), character(kind=4, len=:): &
+!$omp f2b (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2b (omp_priv, omp_orig, .true.))
+!$omp declare reduction (id4:character(kind=4, len=4), character(kind =1, len=4): &
+!$omp f2b (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2b (omp_priv, omp_orig, .true.))
+end subroutine f2
--- gcc/testsuite/gfortran.dg/gomp/udr4.f90.jj	2014-06-02 10:36:19.829284364 +0200
+++ gcc/testsuite/gfortran.dg/gomp/udr4.f90	2014-06-02 10:36:19.829284364 +0200
@@ -0,0 +1,64 @@
+! { dg-do compile }
+
+subroutine f3
+!$omp declare reduction ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction foo ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction (foo) ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction (foo:integer) ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction (foo:integer:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=0) initializer(omp_priv=0) ! { dg-error "Unclassifiable statement" }
+end subroutine f3
+subroutine f4
+  implicit integer (o)
+  implicit real (b)
+!$omp declare reduction (foo:integer:omp_priv(omp_out,omp_in)) ! { dg-error "Implicitly declared subroutine omp_priv" }
+!$omp declare reduction (foo:real:bar(omp_out,omp_in)) ! { dg-error "Implicitly declared subroutine bar used" }
+!$omp declare reduction (bar:integer:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_out (omp_priv)) ! { dg-error "Implicitly declared subroutine omp_out used" }
+!$omp declare reduction (bar:real:omp_out=omp_out+omp_in) &
+!$omp & initializer(bar (omp_priv, omp_orig)) ! { dg-error "Implicitly declared subroutine bar used" }
+!$omp declare reduction (id1:integer:omp_out=omp_orig(omp_out,omp_in)) ! { dg-error "Implicitly declared function omp_orig used" }
+!$omp declare reduction (id1:real:omp_out=foo(omp_out,omp_in)) ! { dg-error "Implicitly declared function foo used" }
+!$omp declare reduction (id2:integer:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv = omp_in (omp_orig)) ! { dg-error "Implicitly declared function omp_in used" }
+!$omp declare reduction (id2:real:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv = baz (omp_orig)) ! { dg-error "Implicitly declared function baz used" }
+end subroutine f4
+subroutine f5
+  interface
+    subroutine f5a (x, *, y)
+      double precision :: x, y
+    end subroutine f5a
+  end interface
+!$omp declare reduction (foo:double precision: & ! { dg-error "Subroutine call with alternate returns in combiner" }
+!$omp & f5a (omp_out, *10, omp_in))
+!$omp declare reduction (bar:double precision: &
+!$omp omp_out = omp_in + omp_out) &
+!$omp & initializer (f5a (omp_priv, *20, omp_orig)) ! { dg-error "Subroutine call with alternate returns in INITIALIZER clause" }
+10 continue
+20 continue
+! { dg-error "Label\[^\n\r]* is never defined" "" { target *-*-* } 0 }
+! { dg-prune-output "<During initialization>" }
+end subroutine f5
+subroutine f6
+  integer :: a
+!$omp declare reduction(foo:character(len=a*2) & ! { dg-error "cannot appear in the expression|not constant" }
+!$omp & :omp_out=trim(omp_out)//omp_in) &
+!$omp & initializer(omp_priv=' ')
+end subroutine f6
+subroutine f7
+  type dt1
+    integer :: a = 1
+    integer :: b
+  end type
+  type dt2
+    integer :: a = 2
+    integer :: b = 3
+  end type
+  type dt3
+    integer :: a
+    integer :: b
+  end type dt3
+!$omp declare reduction(foo:dt1,dt2:omp_out%a=omp_out%a+omp_in%a)
+!$omp declare reduction(foo:dt3:omp_out%a=omp_out%a+omp_in%a) ! { dg-error "Missing INITIALIZER clause for !.OMP DECLARE REDUCTION of derived type without default initializer" }
+end subroutine f7
--- gcc/testsuite/gfortran.dg/gomp/udr5.f90.jj	2014-06-02 10:36:19.829284364 +0200
+++ gcc/testsuite/gfortran.dg/gomp/udr5.f90	2014-06-02 10:36:19.829284364 +0200
@@ -0,0 +1,59 @@
+! { dg-do compile }
+
+module udr5m1
+  type dt
+    real :: r
+  end type dt
+end module udr5m1
+module udr5m2
+  use udr5m1
+  interface operator(+)
+    module procedure addm2
+  end interface
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+  interface operator(.myadd.)
+    module procedure addm2
+  end interface
+contains
+  type(dt) function addm2 (x, y)
+    type(dt), intent (in):: x, y
+    addm2%r = x%r + y%r
+  end function
+end module udr5m2
+module udr5m3
+  use udr5m1
+  interface operator(.myadd.)
+    module procedure addm3
+  end interface
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+  interface operator(+)
+    module procedure addm3
+  end interface
+contains
+  type(dt) function addm3 (x, y)
+    type(dt), intent (in):: x, y
+    addm3%r = x%r + y%r
+  end function
+end module udr5m3
+subroutine f1
+  use udr5m2
+  type(dt) :: d, e
+  integer :: i
+  d=dt(0.0)
+  e = dt (0.0)
+!$omp parallel do reduction (+ : d) reduction ( .myadd. : e)
+  do i=1,100
+    d=d+dt(i)
+    e=e+dt(i)
+  end do
+end subroutine f1
+subroutine f2
+  use udr5m3	! { dg-error "Previous !.OMP DECLARE REDUCTION|Ambiguous interfaces" }
+  use udr5m2	! { dg-error "Ambiguous !.OMP DECLARE REDUCTION" }
+end subroutine f2
--- gcc/testsuite/gfortran.dg/gomp/udr6.f90.jj	2014-06-02 10:49:02.674337338 +0200
+++ gcc/testsuite/gfortran.dg/gomp/udr6.f90	2014-06-02 15:40:52.664740529 +0200
@@ -0,0 +1,205 @@
+! { dg-do compile }
+! { dg-options "-fmax-errors=1000 -fopenmp -ffree-line-length-160" }
+
+module udr6
+  type dt
+    integer :: i
+  end type
+end module udr6
+subroutine f1
+  use udr6, only : dt
+!$omp declare reduction (+:integer:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (+:real(kind=4):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (+:double precision:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (+:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" }
+!$omp & :omp_out = omp_out + omp_in)
+!$omp declare reduction (+:complex:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (+:complex(kind=16):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+  interface operator(+)
+    function addf1 (x, y)
+      use udr6, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: addf1
+    end function
+  end interface
+end subroutine f1
+subroutine f2
+  use udr6, only : dt
+  interface operator(-)
+    function subf2 (x, y)
+      use udr6, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: subf2
+    end function
+  end interface
+!$omp declare reduction (-:integer:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (-:real(kind=4):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (-:double precision:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (-:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" }
+!$omp & :omp_out = omp_out + omp_in)
+!$omp declare reduction (-:complex:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (-:complex(kind=16):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+end subroutine f2
+subroutine f3
+  use udr6, only : dt
+  interface operator(*)
+    function mulf3 (x, y)
+      use udr6, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: mulf3
+    end function
+  end interface
+!$omp declare reduction (*:integer:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (*:real(kind=4):omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (*:double precision:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (*:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" }
+!$omp & :omp_out = omp_out * omp_in)
+!$omp declare reduction (*:complex:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (*:complex(kind=16):omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
+end subroutine f3
+subroutine f4
+  use udr6, only : dt
+  interface operator(.and.)
+    function andf4 (x, y)
+      use udr6, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: andf4
+    end function
+  end interface
+!$omp declare reduction (.neqv.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
+  interface operator(.or.)
+    function orf4 (x, y)
+      use udr6, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: orf4
+    end function
+  end interface
+!$omp declare reduction (.eqv.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
+  interface operator(.eqv.)
+    function eqvf4 (x, y)
+      use udr6, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: eqvf4
+    end function
+  end interface
+!$omp declare reduction (.or.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
+  interface operator(.neqv.)
+    function neqvf4 (x, y)
+      use udr6, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: neqvf4
+    end function
+  end interface
+!$omp declare reduction (.and.:logical:omp_out = omp_out .and. omp_in) ! { dg-error "Redefinition of predefined" }
+end subroutine f4
+subroutine f5
+  use udr6, only : dt
+  interface operator(.and.)
+    function andf5 (x, y)
+      use udr6, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: andf5
+    end function
+  end interface
+!$omp declare reduction (.neqv.:logical(kind =4):omp_out = omp_out .neqv. omp_in) ! { dg-error "Redefinition of predefined" }
+  interface operator(.or.)
+    function orf5 (x, y)
+      use udr6, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: orf5
+    end function
+  end interface
+!$omp declare reduction (.eqv.:logical(kind= 4):omp_out = omp_out .eqv. omp_in) ! { dg-error "Redefinition of predefined" }
+  interface operator(.eqv.)
+    function eqvf5 (x, y)
+      use udr6, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: eqvf5
+    end function
+  end interface
+!$omp declare reduction (.or.:logical(kind=4):omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
+  interface operator(.neqv.)
+    function neqvf5 (x, y)
+      use udr6, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: neqvf5
+    end function
+  end interface
+!$omp declare reduction (.and.:logical(kind = 4):omp_out = omp_out .and. omp_in) ! { dg-error "Redefinition of predefined" }
+end subroutine f5
+subroutine f6
+!$omp declare reduction (min:integer:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:integer:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (iand:integer:omp_out = iand (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (ior:integer:omp_out = ior (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (ieor:integer:omp_out = ieor (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (min:real:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:real:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (min:double precision:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:double precision:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+end subroutine f6
+subroutine f7
+!$omp declare reduction (min:integer(kind=2):omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:integer(kind=4):omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (iand:integer(kind=1):omp_out = iand (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (ior:integer(kind=8):omp_out = ior (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (ieor:integer(kind=4):omp_out = ieor (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (min:real(kind=4):omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:real(kind=4):omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (min:double precision:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:double precision:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+end subroutine f7
+subroutine f8
+  integer :: min
+!$omp declare reduction (min:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (min:real:omp_out = omp_out + omp_in)
+!$omp declare reduction (min:double precision:omp_out = omp_out + omp_in)
+end subroutine f8
+subroutine f9
+  integer :: max
+!$omp declare reduction (max:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (max:real:omp_out = omp_out + omp_in)
+!$omp declare reduction (max:double precision:omp_out = omp_out + omp_in)
+end subroutine f9
+subroutine f10
+  integer :: iand
+!$omp declare reduction (iand:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (iand:real:omp_out = omp_out + omp_in)
+end subroutine f10
+subroutine f11
+  integer :: ior
+!$omp declare reduction (ior:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (ior:real:omp_out = omp_out + omp_in)
+end subroutine f11
+subroutine f12
+  integer :: ieor
+!$omp declare reduction (ieor:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (ieor:real:omp_out = omp_out + omp_in)
+end subroutine f12
+subroutine f13
+!$omp declare reduction (min:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (min:real:omp_out = omp_out + omp_in)
+!$omp declare reduction (min:double precision:omp_out = omp_out + omp_in)
+  integer :: min
+end subroutine f13
+subroutine f14
+!$omp declare reduction (max:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (max:real:omp_out = omp_out + omp_in)
+!$omp declare reduction (max:double precision:omp_out = omp_out + omp_in)
+  integer :: max
+end subroutine f14
+subroutine f15
+!$omp declare reduction (iand:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (iand:real:omp_out = omp_out + omp_in)
+  integer :: iand
+end subroutine f15
+subroutine f16
+!$omp declare reduction (ior:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (ior:real:omp_out = omp_out + omp_in)
+  integer :: ior
+end subroutine f16
+subroutine f17
+!$omp declare reduction (ieor:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (ieor:real:omp_out = omp_out + omp_in)
+  integer :: ieor
+end subroutine f17
--- gcc/testsuite/gfortran.dg/gomp/udr7.f90.jj	2014-06-02 16:16:00.341213345 +0200
+++ gcc/testsuite/gfortran.dg/gomp/udr7.f90	2014-06-02 16:23:52.389793001 +0200
@@ -0,0 +1,90 @@
+! { dg-do compile }
+
+module udr7m1
+  type dt
+    real :: r
+  end type dt
+end module udr7m1
+module udr7m2
+  use udr7m1
+  interface operator(+)
+    module procedure addm2
+  end interface
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+  interface operator(.myadd.)
+    module procedure addm2
+  end interface
+  private
+  public :: operator(+), operator(.myadd.), dt
+contains
+  type(dt) function addm2 (x, y)
+    type(dt), intent (in):: x, y
+    addm2%r = x%r + y%r
+  end function
+end module udr7m2
+module udr7m3
+  use udr7m1
+  private
+  public :: operator(.myadd.), operator(+), dt
+  interface operator(.myadd.)
+    module procedure addm3
+  end interface
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+  interface operator(+)
+    module procedure addm3
+  end interface
+contains
+  type(dt) function addm3 (x, y)
+    type(dt), intent (in):: x, y
+    addm3%r = x%r + y%r
+  end function
+end module udr7m3
+module udr7m4
+  use udr7m1
+  private
+  interface operator(.myadd.)
+    module procedure addm4
+  end interface
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+  interface operator(+)
+    module procedure addm4
+  end interface
+contains
+  type(dt) function addm4 (x, y)
+    type(dt), intent (in):: x, y
+    addm4%r = x%r + y%r
+  end function
+end module udr7m4
+subroutine f1
+  use udr7m2
+  type(dt) :: d, e
+  integer :: i
+  d=dt(0.0)
+  e = dt (0.0)
+!$omp parallel do reduction (+ : d) reduction ( .myadd. : e)
+  do i=1,100
+    d=d+dt(i)
+    e=e+dt(i)
+  end do
+end subroutine f1
+subroutine f2
+  use udr7m3	! { dg-error "Previous !.OMP DECLARE REDUCTION|Ambiguous interfaces" }
+  use udr7m2	! { dg-error "Ambiguous !.OMP DECLARE REDUCTION" }
+end subroutine f2
+subroutine f3
+  use udr7m4
+  use udr7m2
+end subroutine f3
+subroutine f4
+  use udr7m3
+  use udr7m4
+end subroutine f4
--- libgomp/testsuite/libgomp.fortran/simd1.f90.jj	2014-05-30 20:33:46.020078093 +0200
+++ libgomp/testsuite/libgomp.fortran/simd1.f90	2014-06-02 10:36:19.866284172 +0200
@@ -2,22 +2,34 @@
 ! { dg-additional-options "-msse2" { target sse2_runtime } }
 ! { dg-additional-options "-mavx" { target avx_runtime } }
 
-  integer :: i, j, k, l, r, a(30)
+  type dt
+    integer :: x = 0
+  end type
+  type (dt) :: t
+  integer :: i, j, k, l, r, s, a(30)
   integer, target :: q(30)
   integer, pointer :: p(:)
+  !$omp declare reduction (foo : integer : &
+  !$omp & omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+  !$omp declare reduction (+ : dt : omp_out%x = omp_out%x &
+  !$omp & + omp_in%x)
   a(:) = 1
   q(:) = 1
   p => q
   r = 0
   j = 10
   k = 20
-  !$omp simd safelen (8) reduction(+:r) linear(j, k : 2) &
-  !$omp& private (l) aligned(p : 4)
+  s = 0
+  !$omp simd safelen (8) reduction(+:r, t) linear(j, k : 2) &
+  !$omp& private (l) aligned(p : 4) reduction(foo:s)
   do i = 1, 30
     l = j + k + a(i) + p(i)
     r = r + l
     j = j + 2
     k = k + 2
+    s = s + l
+    t%x = t%x + l
   end do
-  if (r.ne.2700.or.j.ne.70.or.k.ne.80) call abort
+  if (r.ne.2700.or.j.ne.70.or.k.ne.80.or.s.ne.2700) call abort
+  if (t%x.ne.2700) call abort
 end
--- libgomp/testsuite/libgomp.fortran/udr1.f90.jj	2014-06-02 10:36:19.867284167 +0200
+++ libgomp/testsuite/libgomp.fortran/udr1.f90	2014-06-02 15:05:47.708571138 +0200
@@ -0,0 +1,51 @@
+! { dg-do run }
+
+module udr1
+  type dt
+    integer :: x = 7
+    integer :: y = 9
+  end type
+end module udr1
+  use udr1, only : dt
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in)
+  integer :: i, j
+!$omp declare reduction (bar : integer : &
+!$omp & omp_out = omp_out + iand (omp_in, -4)) initializer (omp_priv = 3)
+  type (dt) :: d
+!$omp declare reduction (+ : dt : omp_out%x = omp_out%x &
+!$omp & + iand (omp_in%x, -8))
+!$omp declare reduction (foo : dt : omp_out%x = iand (omp_in%x, -8) &
+!$omp & + omp_out%x) initializer (omp_priv = dt (5, 21))
+  interface operator (+)
+    function notdefined(x, y)
+      use udr1, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: notdefined
+    end function
+  end interface
+  j = 0
+!$omp parallel do reduction (foo : j)
+  do i = 1, 100
+    j = j + i
+  end do
+  if (j .ne. 5050) call abort
+  j = 3
+!$omp parallel do reduction (bar : j)
+  do i = 1, 100
+    j = j + 4 * i
+  end do
+  if (j .ne. (5050 * 4 + 3)) call abort
+!$omp parallel do reduction (+ : d)
+  do i = 1, 100
+    if (d%y .ne. 9) call abort
+    d%x = d%x + 8 * i
+  end do
+  if (d%x .ne. (5050 * 8 + 7) .or. d%y .ne. 9) call abort
+  d = dt (5, 21)
+!$omp parallel do reduction (foo : d)
+  do i = 1, 100
+    if (d%y .ne. 21) call abort
+    d%x = d%x + 8 * i
+  end do
+  if (d%x .ne. (5050 * 8 + 5) .or. d%y .ne. 21) call abort
+end
--- libgomp/testsuite/libgomp.fortran/udr2.f90.jj	2014-06-02 10:36:19.867284167 +0200
+++ libgomp/testsuite/libgomp.fortran/udr2.f90	2014-06-02 15:06:43.745275544 +0200
@@ -0,0 +1,51 @@
+! { dg-do run }
+
+module udr2
+  type dt
+    integer :: x = 7
+    integer :: y = 9
+  end type
+end module udr2
+  use udr2, only : dt
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in)
+  integer :: i, j(2:4,3:5)
+!$omp declare reduction (bar : integer : &
+!$omp & omp_out = omp_out + iand (omp_in, -4)) initializer (omp_priv = 3)
+  interface operator (+)
+    function notdefined(x, y)
+      use udr2, only : dt
+      type(dt), intent (in) :: x, y
+      type(dt) :: notdefined
+    end function
+  end interface
+  type (dt) :: d(2:4,3:5)
+!$omp declare reduction (+ : dt : omp_out%x = omp_out%x &
+!$omp & + iand (omp_in%x, -8))
+!$omp declare reduction (foo : dt : omp_out%x = iand (omp_in%x, -8) &
+!$omp & + omp_out%x) initializer (omp_priv = dt (5, 21))
+  j = 0
+!$omp parallel do reduction (foo : j)
+  do i = 1, 100
+    j = j + i
+  end do
+  if (any(j .ne. 5050)) call abort
+  j = 3
+!$omp parallel do reduction (bar : j)
+  do i = 1, 100
+    j = j + 4 * i
+  end do
+  if (any(j .ne. (5050 * 4 + 3))) call abort
+!$omp parallel do reduction (+ : d)
+  do i = 1, 100
+    if (any(d%y .ne. 9)) call abort
+    d%x = d%x + 8 * i
+  end do
+  if (any(d%x .ne. (5050 * 8 + 7)) .or. any(d%y .ne. 9)) call abort
+  d = dt (5, 21)
+!$omp parallel do reduction (foo : d)
+  do i = 1, 100
+    if (any(d%y .ne. 21)) call abort
+    d%x = d%x + 8 * i
+  end do
+  if (any(d%x .ne. (5050 * 8 + 5)) .or. any(d%y .ne. 21)) call abort
+end
--- libgomp/testsuite/libgomp.fortran/udr3.f90.jj	2014-06-02 10:36:19.867284167 +0200
+++ libgomp/testsuite/libgomp.fortran/udr3.f90	2014-06-02 10:36:19.867284167 +0200
@@ -0,0 +1,38 @@
+! { dg-do run }
+
+!$omp declare reduction (foo : character(kind=1, len=*) &
+!$omp & : omp_out = trim(omp_out) // omp_in) initializer (omp_priv = '')
+!$omp declare reduction (bar : character(kind=1, len=:) &
+!$omp & : omp_out = trim(omp_in) // omp_out) initializer (omp_priv = '')
+!$omp declare reduction (baz : character(kind=1, len=1) &
+!$omp & : omp_out = char (ichar (omp_out) + ichar (omp_in) &
+!$omp & - ichar ('0'))) initializer (omp_priv = '0')
+!$omp declare reduction (baz : character(kind=1, len=2) &
+!$omp & : omp_out = char (ichar (omp_out(1:1)) + ichar (omp_in(1:1)) &
+!$omp & - ichar ('0')) // char (ichar (omp_out(2:2)) + &
+!$omp & ichar (omp_in(2:2)) - ichar ('0'))) initializer (omp_priv = '00')
+  character(kind=1, len=64) :: c, d
+  character(kind = 1, len=1) :: e
+  character(kind = 1, len=1+1) :: f
+  integer :: i
+  c = ''
+  d = ''
+  e = '0'
+  f = '00'
+!$omp parallel do reduction (foo : c) reduction (bar : d) &
+!$omp & reduction (baz : e, f)
+  do i = 1, 64
+    c = trim(c) // char (ichar ('0') + i)
+    d = char (ichar ('0') + i) // d
+    e = char (ichar (e) + mod (i, 3))
+    f = char (ichar (f(1:1)) + mod (i, 2)) &
+&	// char (ichar (f(2:2)) + mod (i, 3))
+  end do
+  do i = 1, 64
+    if (index (c, char (ichar ('0') + i)) .eq. 0) call abort
+    if (index (d, char (ichar ('0') + i)) .eq. 0) call abort
+  end do
+  if (e.ne.char (ichar ('0') + 64)) call abort
+  if (f(1:1).ne.char (ichar ('0') + 32)) call abort
+  if (f(2:2).ne.char (ichar ('0') + 64)) call abort
+end
--- libgomp/testsuite/libgomp.fortran/udr4.f90.jj	2014-06-02 10:36:19.867284167 +0200
+++ libgomp/testsuite/libgomp.fortran/udr4.f90	2014-06-02 10:36:19.867284167 +0200
@@ -0,0 +1,39 @@
+! { dg-do run }
+
+!$omp declare reduction (foo : character(kind=1, len=*) &
+!$omp & : omp_out = trim(omp_out) // omp_in) initializer (omp_priv = '')
+!$omp declare reduction (bar : character(kind=1, len=:) &
+!$omp & : omp_out = trim(omp_in) // omp_out) initializer (omp_priv = '')
+!$omp declare reduction (baz : character(kind=1, len=1) &
+!$omp & : omp_out = char (ichar (omp_out) + ichar (omp_in) &
+!$omp & - ichar ('0'))) initializer (omp_priv = '0')
+!$omp declare reduction (baz : character(kind=1, len=2) &
+!$omp & : omp_out = char (ichar (omp_out(1:1)) + ichar (omp_in(1:1)) &
+!$omp & - ichar ('0')) // char (ichar (omp_out(2:2)) + &
+!$omp & ichar (omp_in(2:2)) - ichar ('0'))) initializer (omp_priv = '00')
+  character(kind=1, len=64) :: c(-3:-2,1:1,7:8), d(2:3,-7:-5)
+  character(kind = 1, len=1) :: e(2:4)
+  character(kind = 1, len=1+1) :: f(8:10,9:10)
+  integer :: i, j, k
+  c = ''
+  d = ''
+  e = '0'
+  f = '00'
+!$omp parallel do reduction (foo : c) reduction (bar : d) &
+!$omp & reduction (baz : e, f) private (j, k)
+  do i = 1, 64
+    forall (j = -3:-2, k = 7:8) &
+      c(j,1,k) = trim(c(j,1,k)) // char (ichar ('0') + i)
+    d = char (ichar ('0') + i) // d
+    e = char (ichar (e) + mod (i, 3))
+    f = char (ichar (f(:,:)(1:1)) + mod (i, 2)) &
+&	// char (ichar (f(:,:)(2:2)) + mod (i, 3))
+  end do
+  do i = 1, 64
+    if (any (index (c, char (ichar ('0') + i)) .eq. 0)) call abort
+    if (any (index (d, char (ichar ('0') + i)) .eq. 0)) call abort
+  end do
+  if (any (e.ne.char (ichar ('0') + 64))) call abort
+  if (any (f(:,:)(1:1).ne.char (ichar ('0') + 32))) call abort
+  if (any (f(:,:)(2:2).ne.char (ichar ('0') + 64))) call abort
+end
--- libgomp/testsuite/libgomp.fortran/udr5.f90.jj	2014-06-02 10:36:19.867284167 +0200
+++ libgomp/testsuite/libgomp.fortran/udr5.f90	2014-06-02 10:36:19.867284167 +0200
@@ -0,0 +1,57 @@
+! { dg-do run }
+
+module m
+  interface operator(.add.)
+    module procedure do_add
+  end interface
+  type dt
+    real :: r = 0.0
+  end type
+contains
+  function do_add(x, y)
+    type (dt), intent (in) :: x, y
+    type (dt) :: do_add
+    do_add%r = x%r + y%r
+  end function
+  subroutine dp_add(x, y)
+    double precision :: x, y
+    x = x + y
+  end subroutine
+  subroutine dp_init(x)
+    double precision :: x
+    x = 0.0
+  end subroutine
+end module
+
+program udr5
+  use m, only : operator(.add.), dt, dp_add, dp_init
+  type(dt) :: xdt, one
+  real :: r
+  integer (kind = 4) :: i4
+  integer (kind = 8) :: i8
+  real (kind = 4) :: r4
+  double precision :: dp
+!$omp declare reduction(.add.:dt:omp_out=omp_out.add.omp_in)
+!$omp declare reduction(foo:integer(4),integer(kind=8),real (kind = 4) &
+!$omp & :omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction(foo:double precision:dp_add (omp_out, omp_in)) &
+!$omp & initializer (dp_init (omp_priv))
+
+  one%r = 1.0
+  r = 0.0
+  i4 = 0
+  i8 = 0
+  r4 = 0.0
+  call dp_init (dp)
+!$omp parallel reduction(.add.: xdt) reduction(+: r) &
+!$omp & reduction(foo: i4, i8, r4, dp)
+  xdt = xdt.add.one
+  r = r + 1.0
+  i4 = i4 + 1
+  i8 = i8 + 1
+  r4 = r4 + 1.0
+  call dp_add (dp, 1.0d0)
+!$omp end parallel
+  if (xdt%r .ne. r) call abort
+  if (i4.ne.r.or.i8.ne.r.or.r4.ne.r.or.dp.ne.r) call abort
+end program udr5
--- libgomp/testsuite/libgomp.fortran/udr6.f90.jj	2014-06-02 10:36:19.868284162 +0200
+++ libgomp/testsuite/libgomp.fortran/udr6.f90	2014-06-02 10:36:19.868284162 +0200
@@ -0,0 +1,68 @@
+! { dg-do run }
+
+module m
+  interface operator(.add.)
+    module procedure do_add
+  end interface
+  type dt
+    real :: r = 0.0
+  end type
+contains
+  function do_add(x, y)
+    type (dt), intent (in) :: x, y
+    type (dt) :: do_add
+    do_add%r = x%r + y%r
+  end function
+  subroutine dp_add(x, y)
+    double precision :: x, y
+    x = x + y
+  end subroutine
+  subroutine dp_init(x)
+    double precision :: x
+    x = 0.0
+  end subroutine
+end module
+
+program udr6
+  use m, only : operator(.add.), dt, dp_add, dp_init
+  type(dt), allocatable :: xdt(:)
+  type(dt) :: one
+  real :: r
+  integer (kind = 4), allocatable, dimension(:) :: i4
+  integer (kind = 8), allocatable, dimension(:,:) :: i8
+  integer :: i
+  real (kind = 4), allocatable :: r4(:,:)
+  double precision, allocatable :: dp(:)
+!$omp declare reduction(.add.:dt:omp_out=omp_out.add.omp_in)
+!$omp declare reduction(foo:integer(4),integer(kind=8),real (kind = 4) &
+!$omp & :omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction(foo:double precision:dp_add (omp_out, omp_in)) &
+!$omp & initializer (dp_init (omp_priv))
+
+  one%r = 1.0
+  allocate (xdt(4), i4 (3), i8(-5:-2,2:3), r4(2:5,1:1), dp(7))
+  r = 0.0
+  i4 = 0
+  i8 = 0
+  r4 = 0.0
+  do i = 1, 7
+    call dp_init (dp(i))
+  end do
+!$omp parallel reduction(.add.: xdt) reduction(+: r) &
+!$omp & reduction(foo: i4, i8, r4, dp) private(i)
+  do i = 1, 4
+    xdt(i) = xdt(i).add.one
+  end do
+  r = r + 1.0
+  i4 = i4 + 1
+  i8 = i8 + 1
+  r4 = r4 + 1.0
+  do i = 1, 7
+    call dp_add (dp(i), 1.0d0)
+  end do
+!$omp end parallel
+  if (any (xdt%r .ne. r)) call abort
+  if (any (i4.ne.r).or.any(i8.ne.r)) call abort
+  if (any(r4.ne.r).or.any(dp.ne.r)) call abort
+  deallocate (xdt, i4, i8, r4, dp)
+end program udr6
--- libgomp/testsuite/libgomp.fortran/udr7.f90.jj	2014-06-02 10:36:19.868284162 +0200
+++ libgomp/testsuite/libgomp.fortran/udr7.f90	2014-06-02 10:36:19.868284162 +0200
@@ -0,0 +1,48 @@
+! { dg-do run }
+
+program udr7
+  implicit none
+  interface
+    subroutine omp_priv (x, y, z)
+      real, intent (in) :: x
+      real, intent (inout) :: y
+      real, intent (in) :: z(:)
+    end subroutine omp_priv
+    real function omp_orig (x)
+      real, intent (in) :: x
+    end function omp_orig
+  end interface
+!$omp declare reduction (omp_priv : real : &
+!$omp & omp_priv (omp_orig (omp_in), omp_out, (/ 1.0, 2.0, 3.0 /))) &
+!$omp & initializer (omp_out (omp_priv, omp_in (omp_orig)))
+  real :: x (2:4, 1:1, -2:0)
+  integer :: i
+  x = 0
+!$omp parallel do reduction (omp_priv : x)
+  do i = 1, 64
+    x = x + i
+  end do
+  if (any (x /= 2080.0)) call abort
+contains
+  subroutine omp_out (x, y)
+    real, intent (out) :: x
+    real, intent (in) :: y
+    if (y /= 4.0) call abort
+    x = 0.0
+  end subroutine omp_out
+  real function omp_in (x)
+    real, intent (in) :: x
+    omp_in = x + 4.0
+  end function omp_in
+end program udr7
+subroutine omp_priv (x, y, z)
+  real, intent (in) :: x
+  real, intent (inout) :: y
+  real, intent (in) :: z(:)
+  if (any (z .ne. (/ 1.0, 2.0, 3.0 /))) call abort
+  y = y + (x - 4.0)
+end subroutine omp_priv
+real function omp_orig (x)
+  real, intent (in) :: x
+  omp_orig = x + 4.0
+end function omp_orig
--- libgomp/testsuite/libgomp.fortran/udr8.f90.jj	2014-06-02 10:36:19.868284162 +0200
+++ libgomp/testsuite/libgomp.fortran/udr8.f90	2014-06-02 10:36:19.868284162 +0200
@@ -0,0 +1,46 @@
+! { dg-do run }
+
+module udr8m1
+  integer, parameter :: a = 6
+  integer :: b
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in)
+!$omp declare reduction (.add. : integer : &
+!$omp & omp_out = omp_out .add. iand (omp_in, -4)) &
+!$omp & initializer (omp_priv = 3)
+  interface operator (.add.)
+    module procedure f1
+  end interface
+contains
+  integer function f1 (x, y)
+    integer, intent (in) :: x, y
+    f1 = x + y
+  end function f1
+end module udr8m1
+module udr8m2
+  use udr8m1
+  type dt
+    integer :: x
+  end type
+!$omp declare reduction (+ : dt : omp_out = omp_out + omp_in) &
+!$omp & initializer (omp_priv = dt (0))
+  interface operator (+)
+    module procedure f2
+  end interface
+contains
+  type(dt) function f2 (x, y)
+    type(dt), intent (in) :: x, y
+    f2%x = x%x + y%x
+  end function f2
+end module udr8m2
+  use udr8m2
+  integer :: i, j
+  type(dt) :: d
+  j = 3
+  d%x = 0
+!$omp parallel do reduction (.add.: j) reduction (+ : d)
+  do i = 1, 100
+    j = j.add.iand (i, -4)
+    d = d + dt(i)
+  end do
+  if (d%x /= 5050 .or. j /= 4903) call abort
+end
--- libgomp/testsuite/libgomp.fortran/udr9.f90.jj	2014-06-02 10:36:19.868284162 +0200
+++ libgomp/testsuite/libgomp.fortran/udr9.f90	2014-06-02 10:36:19.868284162 +0200
@@ -0,0 +1,65 @@
+! { dg-do run }
+
+module udr9m1
+  integer, parameter :: a = 6
+  integer :: b
+!$omp declare reduction (foo : integer : combiner1 (omp_out, omp_in)) &
+!$omp & initializer (initializer1 (omp_priv, omp_orig))
+!$omp declare reduction (.add. : integer : &
+!$omp & combiner1 (omp_out, omp_in)) &
+!$omp & initializer (initializer1 (omp_priv, omp_orig))
+  interface operator (.add.)
+    module procedure f1
+  end interface
+contains
+  integer function f1 (x, y)
+    integer, intent (in) :: x, y
+    f1 = x + y
+  end function f1
+  elemental subroutine combiner1 (x, y)
+    integer, intent (inout) :: x
+    integer, intent (in) :: y
+    x = x + iand (y, -4)
+  end subroutine
+  subroutine initializer1 (x, y)
+    integer :: x, y
+    if (y .ne. 3) call abort
+    x = y
+  end subroutine
+end module udr9m1
+module udr9m2
+  use udr9m1
+  type dt
+    integer :: x
+  end type
+!$omp declare reduction (+ : dt : combiner2 (omp_in, omp_out)) &
+!$omp & initializer (initializer2 (omp_priv))
+  interface operator (+)
+    module procedure f2
+  end interface
+contains
+  type(dt) function f2 (x, y)
+    type(dt), intent (in) :: x, y
+    f2%x = x%x + y%x
+  end function f2
+  subroutine combiner2 (x, y)
+    type(dt) :: x, y
+    y = y + x
+  end subroutine combiner2
+  subroutine initializer2 (x)
+    type(dt), intent(out) :: x
+    x%x = 0
+  end subroutine initializer2
+end module udr9m2
+  use udr9m2
+  integer :: i, j
+  type(dt) :: d
+  j = 3
+  d%x = 0
+!$omp parallel do reduction (.add.: j) reduction (+ : d)
+  do i = 1, 100
+    j = j.add.iand (i, -4)
+    d = d + dt(i)
+  end do
+  if (d%x /= 5050 .or. j /= 4903) call abort
+end
--- libgomp/testsuite/libgomp.fortran/udr10.f90.jj	2014-06-02 10:36:19.868284162 +0200
+++ libgomp/testsuite/libgomp.fortran/udr10.f90	2014-06-02 10:36:19.868284162 +0200
@@ -0,0 +1,32 @@
+! { dg-do run }
+
+module udr10m
+  type dt
+    integer :: x = 0
+  end type
+!$omp declare reduction(.add.:dt:omp_out=omp_out.add.omp_in)
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in)
+  interface operator(+)
+    module procedure addme
+  end interface
+  interface operator(.add.)
+    module procedure addme
+  end interface
+contains
+  type(dt) function addme (x, y)
+    type (dt), intent (in) :: x, y
+    addme%x = x%x + y%x
+  end function addme
+end module udr10m
+program udr10
+  use udr10m, only : operator(.localadd.) => operator(.add.), &
+& operator(+), dl => dt
+  type(dl) :: j, k
+  integer :: i
+!$omp parallel do reduction(+:j) reduction(.localadd.:k)
+  do i = 1, 100
+    j = j .localadd. dl(i)
+    k = k + dl(i * 2)
+  end do
+  if (j%x /= 5050 .or. k%x /= 10100) call abort
+end
--- libgomp/testsuite/libgomp.fortran/udr11.f90.jj	2014-06-02 14:51:41.765932756 +0200
+++ libgomp/testsuite/libgomp.fortran/udr11.f90	2014-06-02 15:24:16.077880056 +0200
@@ -0,0 +1,95 @@
+! { dg-do run }
+
+module udr11
+  type dt
+    integer :: x = 0
+  end type
+end module udr11
+  use udr11, only : dt
+!$omp declare reduction(+:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(-:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(*:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(.and.:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(.or.:dt:omp_out%x=omp_out%x+3*omp_in%x)
+!$omp declare reduction(.eqv.:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(.neqv.:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(min:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(max:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(iand:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(ior:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(ieor:dt:omp_out%x=omp_out%x+omp_in%x)
+  interface operator(.and.)
+    function addme1 (x, y)
+      use udr11, only : dt
+      type (dt), intent (in) :: x, y
+      type(dt) :: addme1
+    end function addme1
+  end interface
+  interface operator(.or.)
+    function addme2 (x, y)
+      use udr11, only : dt
+      type (dt), intent (in) :: x, y
+      type(dt) :: addme2
+    end function addme2
+  end interface
+  interface operator(.eqv.)
+    function addme3 (x, y)
+      use udr11, only : dt
+      type (dt), intent (in) :: x, y
+      type(dt) :: addme3
+    end function addme3
+  end interface
+  interface operator(.neqv.)
+    function addme4 (x, y)
+      use udr11, only : dt
+      type (dt), intent (in) :: x, y
+      type(dt) :: addme4
+    end function addme4
+  end interface
+  interface operator(+)
+    function addme5 (x, y)
+      use udr11, only : dt
+      type (dt), intent (in) :: x, y
+      type(dt) :: addme5
+    end function addme5
+  end interface
+  interface operator(-)
+    function addme6 (x, y)
+      use udr11, only : dt
+      type (dt), intent (in) :: x, y
+      type(dt) :: addme6
+    end function addme6
+  end interface
+  interface operator(*)
+    function addme7 (x, y)
+      use udr11, only : dt
+      type (dt), intent (in) :: x, y
+      type(dt) :: addme7
+    end function addme7
+  end interface
+  type(dt) :: j, k, l, m, n, o, p, q, r, s, t, u
+  integer :: i
+!$omp parallel do reduction(.and.:j) reduction(.or.:k) &
+!$omp & reduction(.eqv.:l) reduction(.neqv.:m) &
+!$omp & reduction(min:n) reduction(max:o) &
+!$omp & reduction(iand:p) reduction(ior:q) reduction (ieor:r) &
+!$omp & reduction(+:s) reduction(-:t) reduction(*:u)
+  do i = 1, 100
+    j%x = j%x + i
+    k%x = k%x + 2 * i
+    l%x = l%x + 3 * i
+    m%x = m%x + i
+    n%x = n%x + 2 * i
+    o%x = o%x + 3 * i
+    p%x = p%x + i
+    q%x = q%x + 2 * i
+    r%x = r%x + 3 * i
+    s%x = s%x + i
+    t%x = t%x + 2 * i
+    u%x = u%x + 3 * i
+  end do
+  if (j%x /= 5050 .or. k%x /= 30300 .or. l%x /= 15150) call abort
+  if (m%x /= 5050 .or. n%x /= 10100 .or. o%x /= 15150) call abort
+  if (p%x /= 5050 .or. q%x /= 10100 .or. r%x /= 15150) call abort
+  if (s%x /= 5050 .or. t%x /= 10100 .or. u%x /= 15150) call abort
+end

	Jakub



More information about the Gcc-patches mailing list