gcc/fortran/

2010-08-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/33197
        * gcc/fortran/intrinsic.c (add_functions): Add norm2 and parity.
        * gcc/fortran/intrinsic.h (gfc_check_norm2, gfc_check_parity):
        gfc_simplify_norm2, gfc_simplify_parity, gfc_resolve_norm2,
        gfc_resolve_parity): New prototypes.
        * gcc/fortran/gfortran.h (gfc_isym_id): New enum items
        GFC_ISYM_NORM2 and GFC_ISYM_PARITY.
        * gcc/fortran/iresolve.c (gfc_resolve_norm2,
        gfc_resolve_parity): New functions.
        * gcc/fortran/check.c (gfc_check_norm2, gfc_check_parity):
        New functions.
        * gcc/fortran/trans-intrinsic.c (gfc_conv_intrinsic_arith,
        gfc_conv_intrinsic_function): Handle NORM2 and PARITY.
        * gcc/fortran/intrinsic.texi (NORM2, PARITY): Add.
        * gcc/fortran/simplify.c (simplify_transformation_to_array):
        Add post-processing opterator.
        (gfc_simplify_all, gfc_simplify_any, gfc_simplify_count,
        gfc_simplify_product, gfc_simplify_sum): Update call.
        (add_squared, do_sqrt, gfc_simplify_norm2, do_xor,
        gfc_simplify_parity): New functions.

gcc/testsuite/
2010-08-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/33197
        * gcc/testsuite/gfortran.dg/norm2_1.f90: New.
        * gcc/testsuite/gfortran.dg/norm2_2.f90: New.
        * gcc/testsuite/gfortran.dg/norm2_3.f90: New.
        * gcc/testsuite/gfortran.dg/norm2_4.f90: New.
        * gcc/testsuite/gfortran.dg/parity_1.f90: New.
        * gcc/testsuite/gfortran.dg/parity_2.f90: New.
        * gcc/testsuite/gfortran.dg/parity_3.f90: New.

libgfortran/
2010-08-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/33197
        * libgfortran/m4/ifunction.m4 (FINISH_ARRAY_FUNCTION,
        ARRAY_FUNCTION): Allow expression after loop.
        * libgfortran/m4/norm2.m4: New for _gfortran_norm2_r{4,8,10,16}.
        * libgfortran/m4/parity.m4: New for
        * _gfortran_parity_l{1,2,4,8,16}.
        * libgfortran/gfortran.map: Add new functions.
        * libgfortran/Makefile.am: Ditto.
        * libgfortran/m4/minloc1.m4: Add empty argument for
        * ARRAY_FUNCTION.
        * libgfortran/m4/maxloc1.m4: Ditto.
        * libgfortran/m4/all.m4: Ditto.
        * libgfortran/m4/minval.m4: Ditto.
        * libgfortran/m4/maxval.m4: Ditto.
        * libgfortran/m4/count.m4: Ditto.
        * libgfortran/m4/product.m4: Ditto.
        * libgfortran/m4/any.m4: Ditto.
        * Makefile.in: Regenerated.
        * generated/minval_r8.c: Regenerated.
        * generated/maxloc1_4_r8.c: Regenerated.
        * generated/minloc1_16_r16.c: Regenerated.
        * generated/norm2_r4.c: Regenerated.
        * generated/sum_i8.c: Regenerated.
        * generated/parity_l2.c: Regenerated.
        * generated/any_l16.c: Regenerated.
        * generated/maxval_i2.c: Regenerated.
        * generated/any_l2.c: Regenerated.
        * generated/product_r4.c: Regenerated.
        * generated/maxloc1_8_i4.c: Regenerated.
        * generated/parity_l16.c: Regenerated.
        * generated/all_l1.c: Regenerated.
        * generated/product_i2.c: Regenerated.
        * generated/minloc1_8_r16.c: Regenerated.
        * generated/maxloc1_8_r16.c: Regenerated.
        * generated/sum_r16.c: Regenerated.
        * generated/sum_i1.c: Regenerated.
        * generated/minloc1_4_r8.c: Regenerated.
        * generated/maxloc1_16_r16.c: Regenerated.
        * generated/minloc1_16_i4.c: Regenerated.
        * generated/maxloc1_16_i4.c: Regenerated.
        * generated/maxval_r16.c: Regenerated.
        * generated/product_c10.c: Regenerated.
        * generated/minloc1_8_i4.c: Regenerated.
        * generated/all_l2.c: Regenerated.
        * generated/product_c4.c: Regenerated.
        * generated/sum_r4.c: Regenerated.
        * generated/all_l16.c: Regenerated.
        * generated/minloc1_16_r10.c: Regenerated.
        * generated/sum_i2.c: Regenerated.
        * generated/maxloc1_8_r8.c: Regenerated.
        * generated/minval_i16.c: Regenerated.
        * generated/parity_l4.c: Regenerated.
        * generated/maxval_i4.c: Regenerated.
        * generated/any_l4.c: Regenerated.
        * generated/minval_i8.c: Regenerated.
        * generated/maxloc1_4_i8.c: Regenerated.
        * generated/minloc1_4_i16.c: Regenerated.
        * generated/maxloc1_4_i16.c: Regenerated.
        * generated/minloc1_8_r10.c: Regenerated.
        * generated/product_i4.c: Regenerated.
        * generated/maxloc1_8_r10.c: Regenerated.
        * generated/sum_c16.c: Regenerated.
        * generated/minloc1_16_r8.c: Regenerated.
        * generated/maxloc1_16_r8.c: Regenerated.
        * generated/count_4_l.c: Regenerated.
        * generated/sum_r10.c: Regenerated.
        * generated/count_8_l.c: Regenerated.
        * generated/sum_c4.c: Regenerated.
        * generated/maxloc1_16_r10.c: Regenerated.
        * generated/minloc1_8_r8.c: Regenerated.
        * generated/maxval_r10.c: Regenerated.
        * generated/minval_i1.c: Regenerated.
        * generated/maxloc1_4_i1.c: Regenerated.
        * generated/minloc1_4_i8.c: Regenerated.
        * generated/product_i16.c: Regenerated.
        * generated/all_l4.c: Regenerated.
        * generated/norm2_r16.c: Regenerated.
        * generated/minval_r4.c: Regenerated.
        * generated/maxloc1_4_r4.c: Regenerated.
        * generated/sum_i4.c: Regenerated.
        * generated/maxval_r8.c: Regenerated.
        * generated/norm2_r8.c: Regenerated.
        * generated/minloc1_4_i1.c: Regenerated.
        * generated/minval_r16.c: Regenerated.
        * generated/minval_i2.c: Regenerated.
        * generated/maxloc1_4_i2.c: Regenerated.
        * generated/product_r8.c: Regenerated.
        * generated/maxloc1_8_i8.c: Regenerated.
        * generated/sum_c10.c: Regenerated.
        * generated/minloc1_4_r16.c: Regenerated.
        * generated/maxloc1_4_r16.c: Regenerated.
        * generated/count_1_l.c: Regenerated.
        * generated/minloc1_4_r4.c: Regenerated.
        * generated/minloc1_16_i8.c: Regenerated.
        * generated/maxloc1_16_i8.c: Regenerated.
        * generated/minloc1_4_i2.c: Regenerated.
        * generated/maxloc1_8_i1.c: Regenerated.
        * generated/minloc1_8_i8.c: Regenerated.
        * generated/product_r16.c: Regenerated.
        * generated/product_c8.c: Regenerated.
        * generated/sum_r8.c: Regenerated.
        * generated/norm2_r10.c: Regenerated.
        * generated/minloc1_16_i16.c: Regenerated.
        * generated/maxloc1_8_r4.c: Regenerated.
        * generated/minloc1_16_i1.c: Regenerated.
        * generated/maxloc1_16_i1.c: Regenerated.
        * generated/minval_r10.c: Regenerated.
        * generated/count_16_l.c: Regenerated.
        * generated/parity_l8.c: Regenerated.
        * generated/minloc1_8_i1.c: Regenerated.
        * generated/minval_i4.c: Regenerated.
        * generated/maxloc1_4_i4.c: Regenerated.
        * generated/maxloc1_8_i2.c: Regenerated.
        * generated/maxval_i8.c: Regenerated.
        * generated/any_l8.c: Regenerated.
        * generated/minloc1_4_r10.c: Regenerated.
        * generated/minloc1_8_i16.c: Regenerated.
        * generated/maxloc1_4_r10.c: Regenerated.
        * generated/maxloc1_8_i16.c: Regenerated.
        * generated/minloc1_16_r4.c: Regenerated.
        * generated/maxloc1_16_r4.c: Regenerated.
        * generated/product_i8.c: Regenerated.
        * generated/sum_i16.c: Regenerated.
        * generated/count_2_l.c: Regenerated.
        * generated/maxloc1_16_i16.c: Regenerated.
        * generated/minloc1_8_r4.c: Regenerated.
        * generated/sum_c8.c: Regenerated.
        * generated/minloc1_16_i2.c: Regenerated.
        * generated/maxloc1_16_i2.c: Regenerated.
        * generated/parity_l1.c: Regenerated.
        * generated/maxval_i16.c: Regenerated.
        * generated/maxval_i1.c: Regenerated.
        * generated/minloc1_4_i4.c: Regenerated.
        * generated/any_l1.c: Regenerated.
        * generated/minloc1_8_i2.c: Regenerated.
        * generated/product_c16.c: Regenerated.
        * generated/product_r10.c: Regenerated.
        * generated/product_i1.c: Regenerated.
        * generated/all_l8.c: Regenerated.
        * generated/maxval_r4.c: Regenerated.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@163595 138bc75d-0d04-0410-961f-82ee72b054a4

9 files changed, 433 insertions, 18 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a15c13663ef..ba1ee59c917 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,26 @@
+2010-08-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33197
+	* gcc/fortran/intrinsic.c (add_functions): Add norm2 and parity.
+	* gcc/fortran/intrinsic.h (gfc_check_norm2, gfc_check_parity):
+	gfc_simplify_norm2, gfc_simplify_parity, gfc_resolve_norm2,
+	gfc_resolve_parity): New prototypes.
+	* gcc/fortran/gfortran.h (gfc_isym_id): New enum items
+	GFC_ISYM_NORM2 and GFC_ISYM_PARITY.
+	* gcc/fortran/iresolve.c (gfc_resolve_norm2,
+	gfc_resolve_parity): New functions.
+	* gcc/fortran/check.c (gfc_check_norm2, gfc_check_parity):
+	New functions.
+	* gcc/fortran/trans-intrinsic.c (gfc_conv_intrinsic_arith,
+	gfc_conv_intrinsic_function): Handle NORM2 and PARITY.
+	* gcc/fortran/intrinsic.texi (NORM2, PARITY): Add.
+	* gcc/fortran/simplify.c (simplify_transformation_to_array):
+	Add post-processing opterator.
+	(gfc_simplify_all, gfc_simplify_any, gfc_simplify_count,
+	gfc_simplify_product, gfc_simplify_sum): Update call.
+	(add_squared, do_sqrt, gfc_simplify_norm2, do_xor,
+	gfc_simplify_parity): New functions.
+
 2010-08-27  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/45420
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 36efffa6dfa..0ff6b6e4cee 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2432,6 +2432,21 @@ gfc_check_new_line (gfc_expr *a)
 
 
 gfc_try
+gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
+{
+  if (type_check (array, 0, BT_REAL) == FAILURE)
+    return FAILURE;
+
+  if (array_check (array, 0) == FAILURE)
+    return FAILURE;
+
+  if (dim_rank_check (dim, array, false) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+gfc_try
 gfc_check_null (gfc_expr *mold)
 {
   symbol_attribute attr;
@@ -2540,6 +2555,22 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
 
 
 gfc_try
+gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
+{
+  if (type_check (mask, 0, BT_LOGICAL) == FAILURE)
+    return FAILURE;
+
+  if (array_check (mask, 0) == FAILURE)
+    return FAILURE;
+
+  if (dim_rank_check (dim, mask, false) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+gfc_try
 gfc_check_precision (gfc_expr *x)
 {
   if (real_or_complex_check (x, 0) == FAILURE)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index c84c63387a2..0a2f52f9e9a 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -464,11 +464,13 @@ enum gfc_isym_id
   GFC_ISYM_NEAREST,
   GFC_ISYM_NEW_LINE,
   GFC_ISYM_NINT,
+  GFC_ISYM_NORM2,
   GFC_ISYM_NOT,
   GFC_ISYM_NULL,
   GFC_ISYM_NUMIMAGES,
   GFC_ISYM_OR,
   GFC_ISYM_PACK,
+  GFC_ISYM_PARITY,
   GFC_ISYM_PERROR,
   GFC_ISYM_PRECISION,
   GFC_ISYM_PRESENT,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 9087106d958..2ce3482e3a1 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -2268,6 +2268,13 @@ add_functions (void)
 
   make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
 
+  add_sym_2 ("norm2", GFC_ISYM_NORM2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr,
+	     GFC_STD_F2008, gfc_check_norm2, gfc_simplify_norm2, gfc_resolve_norm2,
+	     x, BT_REAL, dr, REQUIRED,
+	     dm, BT_INTEGER, ii, OPTIONAL);
+
+  make_generic ("norm2", GFC_ISYM_NORM2, GFC_STD_F2008);
+
   add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
 	     gfc_check_null, gfc_simplify_null, NULL,
 	     mo, BT_INTEGER, di, OPTIONAL);
@@ -2284,6 +2291,14 @@ add_functions (void)
 
   make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
 
+
+  add_sym_2 ("parity", GFC_ISYM_PARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl,
+	     GFC_STD_F2008, gfc_check_parity, gfc_simplify_parity, gfc_resolve_parity,
+	     msk, BT_LOGICAL, dl, REQUIRED,
+	     dm, BT_INTEGER, ii, OPTIONAL);
+
+  make_generic ("parity", GFC_ISYM_PARITY, GFC_STD_F2008);
+
   add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
 	     gfc_check_precision, gfc_simplify_precision, NULL,
 	     x, BT_UNKNOWN, 0, REQUIRED);
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 5de0116ecdb..2c101d391be 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -108,8 +108,10 @@ gfc_try gfc_check_minloc_maxloc (gfc_actual_arglist *);
 gfc_try gfc_check_minval_maxval (gfc_actual_arglist *);
 gfc_try gfc_check_nearest (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_new_line (gfc_expr *);
+gfc_try gfc_check_norm2 (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_null (gfc_expr *);
 gfc_try gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_try gfc_check_parity (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_precision (gfc_expr *);
 gfc_try gfc_check_present (gfc_expr *);
 gfc_try gfc_check_product_sum (gfc_actual_arglist *);
@@ -307,12 +309,14 @@ gfc_expr *gfc_simplify_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
 gfc_expr *gfc_simplify_nearest (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_new_line (gfc_expr *);
 gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_norm2 (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_null (gfc_expr *);
 gfc_expr *gfc_simplify_num_images (void);
 gfc_expr *gfc_simplify_idnint (gfc_expr *);
 gfc_expr *gfc_simplify_not (gfc_expr *);
 gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_pack (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_parity (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_precision (gfc_expr *);
 gfc_expr *gfc_simplify_product (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_radix (gfc_expr *);
@@ -473,9 +477,11 @@ void gfc_resolve_mod (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_modulo (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_nearest (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_nint (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_norm2 (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_not (gfc_expr *, gfc_expr *);
 void gfc_resolve_or (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_pack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_parity (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_product (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_real (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_realpart (gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index f258e517674..c4767f5a6eb 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -203,11 +203,13 @@ Some basic guidelines for editing this document:
 * @code{NEAREST}:       NEAREST,   Nearest representable number
 * @code{NEW_LINE}:      NEW_LINE,  New line character
 * @code{NINT}:          NINT,      Nearest whole number
+* @code{NORM2}:         NORM2,     Euclidean vector norm
 * @code{NOT}:           NOT,       Logical negation
 * @code{NULL}:          NULL,      Function that returns an disassociated pointer
 * @code{NUM_IMAGES}:    NUM_IMAGES, Number of images
 * @code{OR}:            OR,        Bitwise logical OR
 * @code{PACK}:          PACK,      Pack an array into an array of rank one
+* @code{PARITY}:        PARITY,    Reduction with exclusive OR
 * @code{PERROR}:        PERROR,    Print system error message
 * @code{PRECISION}:     PRECISION, Decimal precision of a real kind
 * @code{PRESENT}:       PRESENT,   Determine whether an optional dummy argument is specified
@@ -8471,6 +8473,57 @@ end program test_nint
 
 
 
+@node NORM2
+@section @code{NORM2} --- Euclidean vector norms
+@fnindex NORM2
+@cindex Euclidean vector norm
+@cindex L2 vector norm
+@cindex norm, Euclidean
+
+@table @asis
+@item @emph{Description}:
+Calculates the Euclidean vector norm (@math{L_2}) norm of
+of @var{ARRAY} along dimension @var{DIM}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = NORM2(ARRAY[, DIM])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{REAL}
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{ARRAY}.
+
+If @var{DIM} is absent, a scalar with the square root of the sum of all
+elements in @var{ARRAY} squared  is returned. Otherwise, an array of
+rank @math{n-1}, where @math{n} equals the rank of @var{ARRAY}, and a
+shape similar to that of @var{ARRAY} with dimension @var{DIM} dropped
+is returned.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_sum
+  REAL :: x(5) = [ real :: 1, 2, 3, 4, 5 ]
+  print *, NORM2(x)  ! = sqrt(55.) ~ 7.416
+END PROGRAM
+@end smallexample
+@end table
+
+
+
 @node NOT
 @section @code{NOT} --- Logical negation
 @fnindex NOT
@@ -8717,6 +8770,58 @@ END PROGRAM
 
 
 
+@node PARITY
+@section @code{PARITY} --- Reduction with exclusive OR
+@fnindex PARITY
+@cindex Parity
+@cindex Reduction, XOR
+@cindex XOR reduction
+
+@table @asis
+@item @emph{Description}:
+Calculates the partity, i.e. the reduction using @code{.XOR.},
+of @var{MASK} along dimension @var{DIM}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = PARITY(MASK[, DIM])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{LOGICAL} @tab Shall be an array of type @code{LOGICAL}
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{MASK}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{MASK}.
+
+If @var{DIM} is absent, a scalar with the parity of all elements in
+@var{MASK} is returned, i.e. true if an odd number of elements is
+@code{.true.} and false otherwise.  If @var{DIM} is present, an array
+of rank @math{n-1}, where @math{n} equals the rank of @var{ARRAY},
+and a shape similar to that of @var{MASK} with dimension @var{DIM}
+dropped is returned.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_sum
+  LOGICAL :: x(2) = [ .true., .false. ]
+  print *, PARITY(x) ! prints "T" (true).
+END PROGRAM
+@end smallexample
+@end table
+
+
+
 @node PERROR
 @section @code{PERROR} --- Print system error message
 @fnindex PERROR
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 6565187423e..5a187ee455e 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1825,6 +1825,23 @@ gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 
 
 void
+gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+  f->ts = array->ts;
+
+  if (dim != NULL)
+    {
+      f->rank = array->rank - 1;
+      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+      gfc_resolve_dim_arg (dim);
+    }
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("norm2_r%d"), array->ts.kind);
+}
+
+
+void
 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
 {
   f->ts = i->ts;
@@ -1889,6 +1906,25 @@ gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
 
 
 void
+gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+  f->ts = array->ts;
+
+  if (dim != NULL)
+    {
+      f->rank = array->rank - 1;
+      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+      gfc_resolve_dim_arg (dim);
+    }
+
+  resolve_mask_arg (array);
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("parity_l%d"), array->ts.kind);
+}
+
+
+void
 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
 		     gfc_expr *mask)
 {
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 4cb29fbfc67..98955bb0a3e 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -488,11 +488,12 @@ simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *
      REAL, PARAMETER :: array(n, m) = ...
      REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
 
-  where OP == gfc_multiply().  */
+  where OP == gfc_multiply(). The result might be post processed using post_op. */ 
 
 static gfc_expr *
 simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
-				  gfc_expr *mask, transformational_op op)
+				  gfc_expr *mask, transformational_op op,
+				  transformational_op post_op)
 {
   mpz_t size;
   int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
@@ -606,7 +607,10 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d
   result_ctor = gfc_constructor_first (result->value.constructor);
   for (i = 0; i < resultsize; ++i)
     {
-      result_ctor->expr = resultvec[i];
+      if (post_op)
+	result_ctor->expr = post_op (result_ctor->expr, resultvec[i]);
+      else
+	result_ctor->expr = resultvec[i];
       result_ctor = gfc_constructor_next (result_ctor);
     }
 
@@ -896,7 +900,7 @@ gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
 
   return !dim || mask->rank == 1 ?
     simplify_transformation_to_scalar (result, mask, NULL, gfc_and) :
-    simplify_transformation_to_array (result, mask, dim, NULL, gfc_and);
+    simplify_transformation_to_array (result, mask, dim, NULL, gfc_and, NULL);
 }
 
 
@@ -982,7 +986,7 @@ gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
 
   return !dim || mask->rank == 1 ?
     simplify_transformation_to_scalar (result, mask, NULL, gfc_or) :
-    simplify_transformation_to_array (result, mask, dim, NULL, gfc_or);
+    simplify_transformation_to_array (result, mask, dim, NULL, gfc_or, NULL);
 }
 
 
@@ -1679,7 +1683,7 @@ gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
      Whenever gfc_count is called, '1' is added to the result.  */
   return !dim || mask->rank == 1 ?
     simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
-    simplify_transformation_to_array (result, mask, dim, mask, gfc_count);
+    simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
 }
 
 
@@ -4048,6 +4052,65 @@ gfc_simplify_idnint (gfc_expr *e)
 }
 
 
+static gfc_expr *
+add_squared (gfc_expr *result, gfc_expr *e)
+{
+  mpfr_t tmp;
+
+  gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_REAL
+	      && result->expr_type == EXPR_CONSTANT);
+
+  gfc_set_model_kind (result->ts.kind);
+  mpfr_init (tmp);
+  mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
+  mpfr_add (result->value.real, result->value.real, tmp,
+	    GFC_RND_MODE);
+  mpfr_clear (tmp);
+
+  return result;
+}
+
+
+static gfc_expr *
+do_sqrt (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_REAL
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
+  mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (e)
+      || (dim != NULL && !gfc_is_constant_expr (dim)))
+    return NULL;
+
+  result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
+  init_result_expr (result, 0, NULL);
+
+  if (!dim || e->rank == 1)
+    {
+      result = simplify_transformation_to_scalar (result, e, NULL,
+						  add_squared);
+      mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
+    }
+  else
+    result = simplify_transformation_to_array (result, e, dim, NULL,
+					       add_squared, &do_sqrt);
+
+  return result;
+}
+
+
 gfc_expr *
 gfc_simplify_not (gfc_expr *e)
 {
@@ -4198,6 +4261,37 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
 }
 
 
+static gfc_expr *
+do_xor (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_LOGICAL
+	      && result->expr_type == EXPR_CONSTANT);
+
+  result->value.logical = result->value.logical != e->value.logical;
+  return result;
+}
+
+
+
+gfc_expr *
+gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (e)
+      || (dim != NULL && !gfc_is_constant_expr (dim)))
+    return NULL;
+
+  result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
+  init_result_expr (result, 0, NULL);
+
+  return (!dim || e->rank == 1)
+    ? simplify_transformation_to_scalar (result, e, NULL, do_xor)
+    : simplify_transformation_to_array (result, e, dim, NULL, do_xor, NULL);
+}
+
+
 gfc_expr *
 gfc_simplify_precision (gfc_expr *e)
 {
@@ -4227,7 +4321,7 @@ gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 
   return !dim || array->rank == 1 ?
     simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
-    simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
+    simplify_transformation_to_array (result, array, dim, mask, gfc_multiply, NULL);
 }
 
 
@@ -5390,7 +5484,7 @@ gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 
   return !dim || array->rank == 1 ?
     simplify_transformation_to_scalar (result, array, mask, gfc_add) :
-    simplify_transformation_to_array (result, array, dim, mask, gfc_add);
+    simplify_transformation_to_array (result, array, dim, mask, gfc_add, NULL);
 }
 
 
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 373770fef7d..e0805d09571 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1810,9 +1810,11 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
 
 /* Inline implementation of the sum and product intrinsics.  */
 static void
-gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
+gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
+			  bool norm2)
 {
   tree resvar;
+  tree scale = NULL_TREE;
   tree type;
   stmtblock_t body;
   stmtblock_t block;
@@ -1835,8 +1837,20 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
   type = gfc_typenode_for_spec (&expr->ts);
   /* Initialize the result.  */
   resvar = gfc_create_var (type, "val");
-  if (op == PLUS_EXPR)
+  if (norm2)
+    {
+      /* result = 0.0;
+	 scale = 1.0.  */
+      scale = gfc_create_var (type, "scale");
+      gfc_add_modify (&se->pre, scale,
+		      gfc_build_const (type, integer_one_node));
+      tmp = gfc_build_const (type, integer_zero_node);
+    }
+  else if (op == PLUS_EXPR)
     tmp = gfc_build_const (type, integer_zero_node);
+  else if (op == NE_EXPR)
+    /* PARITY.  */
+    tmp = convert (type, boolean_false_node);
   else
     tmp = gfc_build_const (type, integer_one_node);
 
@@ -1848,9 +1862,16 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
   arrayss = gfc_walk_expr (arrayexpr);
   gcc_assert (arrayss != gfc_ss_terminator);
 
-  actual = actual->next->next;
-  gcc_assert (actual);
-  maskexpr = actual->expr;
+  if (op == NE_EXPR || norm2)
+    /* PARITY and NORM2.  */
+    maskexpr = NULL;
+  else
+    {
+      actual = actual->next->next;
+      gcc_assert (actual);
+      maskexpr = actual->expr;
+    }
+
   if (maskexpr && maskexpr->rank != 0)
     {
       maskss = gfc_walk_expr (maskexpr);
@@ -1896,15 +1917,77 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
   gfc_conv_expr_val (&arrayse, arrayexpr);
   gfc_add_block_to_block (&block, &arrayse.pre);
 
-  tmp = fold_build2 (op, type, resvar, arrayse.expr);
-  gfc_add_modify (&block, resvar, tmp);
+  if (norm2)
+    {
+      /* if (x(i) != 0.0)
+	   {
+	     absX = abs(x(i))
+	     if (absX > scale)
+	       {
+                 val = scale/absX;
+		 result = 1.0 + result * val * val;
+		 scale = absX;
+	       }
+	     else
+	       {
+                 val = absX/scale;
+	         result += val * val;
+	       }
+	   }  */
+      tree res1, res2, cond, absX, val;
+      stmtblock_t ifblock1, ifblock2, ifblock3;
+
+      gfc_init_block (&ifblock1);
+
+      absX = gfc_create_var (type, "absX");
+      gfc_add_modify (&ifblock1, absX,
+		      fold_build1 (ABS_EXPR, type, arrayse.expr));
+      val = gfc_create_var (type, "val");
+      gfc_add_expr_to_block (&ifblock1, val);
+
+      gfc_init_block (&ifblock2);
+      gfc_add_modify (&ifblock2, val,
+		      fold_build2 (RDIV_EXPR, type, scale, absX));
+      res1 = fold_build2 (MULT_EXPR, type, val, val); 
+      res1 = fold_build2 (MULT_EXPR, type, resvar, res1);
+      res1 = fold_build2 (PLUS_EXPR, type, res1,
+			  gfc_build_const (type, integer_one_node));
+      gfc_add_modify (&ifblock2, resvar, res1);
+      gfc_add_modify (&ifblock2, scale, absX);
+      res1 = gfc_finish_block (&ifblock2); 
+
+      gfc_init_block (&ifblock3);
+      gfc_add_modify (&ifblock3, val,
+		      fold_build2 (RDIV_EXPR, type, absX, scale));
+      res2 = fold_build2 (MULT_EXPR, type, val, val); 
+      res2 = fold_build2 (PLUS_EXPR, type, resvar, res2);
+      gfc_add_modify (&ifblock3, resvar, res2);
+      res2 = gfc_finish_block (&ifblock3);
+
+      cond = fold_build2 (GT_EXPR, boolean_type_node, absX, scale);
+      tmp = build3_v (COND_EXPR, cond, res1, res2);
+      gfc_add_expr_to_block (&ifblock1, tmp);  
+      tmp = gfc_finish_block (&ifblock1);
+
+      cond = fold_build2 (NE_EXPR, boolean_type_node, arrayse.expr,
+			  gfc_build_const (type, integer_zero_node));
+
+      tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);  
+    }
+  else
+    {
+      tmp = fold_build2 (op, type, resvar, arrayse.expr);
+      gfc_add_modify (&block, resvar, tmp);
+    }
+
   gfc_add_block_to_block (&block, &arrayse.post);
 
   if (maskss)
     {
       /* We enclose the above in if (mask) {...} .  */
-      tmp = gfc_finish_block (&block);
 
+      tmp = gfc_finish_block (&block);
       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
 		      build_empty_stmt (input_location));
     }
@@ -1937,6 +2020,16 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
 
   gfc_cleanup_loop (&loop);
 
+  if (norm2)
+    {
+      /* result = scale * sqrt(result).  */
+      tree sqrt;
+      sqrt = builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
+      resvar = build_call_expr_loc (input_location,
+				    sqrt, 1, resvar);
+      resvar = fold_build2 (MULT_EXPR, type, scale, resvar);
+    }
+
   se->expr = resvar;
 }
 
@@ -5288,6 +5381,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_nearest (se, expr);
       break;
 
+    case GFC_ISYM_NORM2:
+      gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
+      break;
+
     case GFC_ISYM_NOT:
       gfc_conv_intrinsic_not (se, expr);
       break;
@@ -5296,12 +5393,16 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
       break;
 
+    case GFC_ISYM_PARITY:
+      gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
+      break;
+
     case GFC_ISYM_PRESENT:
       gfc_conv_intrinsic_present (se, expr);
       break;
 
     case GFC_ISYM_PRODUCT:
-      gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
+      gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
       break;
 
     case GFC_ISYM_RRSPACING:
@@ -5338,7 +5439,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_SUM:
-      gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
+      gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
       break;
 
     case GFC_ISYM_TRANSFER:
@@ -5508,6 +5609,8 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
     case GFC_ISYM_MAXVAL:
     case GFC_ISYM_MINLOC:
     case GFC_ISYM_MINVAL:
+    case GFC_ISYM_NORM2:
+    case GFC_ISYM_PARITY:
     case GFC_ISYM_PRODUCT:
     case GFC_ISYM_SUM:
     case GFC_ISYM_SHAPE: