diff options
| author | François-Xavier Coudert <fxcoudert@gcc.gnu.org> | 2005-10-03 07:22:20 +0000 |
|---|---|---|
| committer | François-Xavier Coudert <fxcoudert@gcc.gnu.org> | 2005-10-03 07:22:20 +0000 |
| commit | 644cb69f803dc904c271885272e70f032ce56a97 (patch) | |
| tree | 8bb857b1bc8bb03e3ba5509a8bba4513942fff4a /libgfortran/generated | |
| parent | 41a182c62d6314c2c3c138ebe358da485691f1b7 (diff) | |
| download | gcc-644cb69f803dc904c271885272e70f032ce56a97.tar.gz | |
re PR libfortran/19308 (I/O library should support more real and integer kinds)
PR libfortran/19308
PR fortran/20120
PR libfortran/22437
* Makefile.am: Add generated files for large real and integers
kinds. Add a rule to create the kinds.inc c99_protos.inc files.
Use kinds.inc to preprocess Fortran generated files.
* libgfortran.h: Add macro definitions for GFC_INTEGER_16_HUGE,
GFC_REAL_10_HUGE and GFC_REAL_16_HUGE. Add types gfc_array_i16,
gfc_array_r10, gfc_array_r16, gfc_array_c10, gfc_array_c16,
gfc_array_l16.
* mk-kinds-h.sh: Define macros HAVE_GFC_LOGICAL_* and
HAVE_GFC_COMPLEX_* when these types are available.
* intrinsics/ishftc.c (ishftc16): New function for GFC_INTEGER_16.
* m4/all.m4, m4/any.m4, m4/count.m4, m4/cshift1.m4, m4/dotprod.m4,
m4/dotprodc.m4, m4/dotprodl.m4, m4/eoshift1.m4, m4/eoshift3.m4,
m4/exponent.m4, m4/fraction.m4, m4/in_pack.m4, m4/in_unpack.m4,
m4/matmul.m4, m4/matmull.m4, m4/maxloc0.m4, m4/maxloc1.m4,
m4/maxval.m4, m4/minloc0.m4, m4/minloc1.m4, m4/minval.m4, m4/mtype.m4,
m4/nearest.m4, m4/pow.m4, m4/product.m4, m4/reshape.m4,
m4/set_exponent.m4, m4/shape.m4, m4/specific.m4, m4/specific2.m4,
m4/sum.m4, m4/transpose.m4: Protect generated functions with
appropriate "#if defined (HAVE_GFC_type_kind)" preprocessor directives.
* Makefile.in: Regenerate.
* all files in generated/: Regenerate.
* f95-lang.c (DO_DEFINE_MATH_BUILTIN): Add support for long
double builtin function.
(gfc_init_builtin_functions): Add mfunc_longdouble,
mfunc_clongdouble and func_clongdouble_longdouble trees. Build
them for round, trunc, cabs, copysign and pow functions.
* iresolve.c (gfc_resolve_reshape, gfc_resolve_transpose): Add
case for kind 10 and 16.
* trans-decl.c: Add trees for cpowl10, cpowl16, ishftc16,
exponent10 and exponent16.
(gfc_build_intrinsic_function_decls): Build nodes for int16,
real10, real16, complex10 and complex16 types. Build all possible
combinations for function _gfortran_pow_?n_?n. Build function
calls cpowl10, cpowl16, ishftc16, exponent10 and exponent16.
* trans-expr.c (gfc_conv_power_op): Add case for integer(16),
real(10) and real(16).
* trans-intrinsic.c: Add suppport for long double builtin
functions in BUILT_IN_FUNCTION, LIBM_FUNCTION and LIBF_FUNCTION
macros.
(gfc_conv_intrinsic_aint): Add case for integer(16), real(10) and
real(16) kinds.
(gfc_build_intrinsic_lib_fndecls): Add support for real10_decl
and real16_decl in library functions.
(gfc_get_intrinsic_lib_fndecl): Add cases for real and complex
kinds 10 and 16.
(gfc_conv_intrinsic_exponent): Add cases for real(10) and real(16)
kinds.
(gfc_conv_intrinsic_sign): Likewise.
(gfc_conv_intrinsic_ishftc): Add case for integer(16) kind.
* trans-types.c (gfc_get_int_type, gfc_get_real_type,
gfc_get_complex_type, gfc_get_logical_type): Doesn't error out in
the case of kinds not available.
* trans.h: Declare trees for cpowl10, cpowl16, ishftc16,
exponent10 and exponent16.
* gfortran.dg/large_real_kind_2.F90: New test.
* gfortran.dg/large_integer_kind_2.f90: New test.
From-SVN: r104889
Diffstat (limited to 'libgfortran/generated')
370 files changed, 33763 insertions, 0 deletions
diff --git a/libgfortran/generated/_abs_c10.F90 b/libgfortran/generated/_abs_c10.F90 new file mode 100644 index 00000000000..8e76b3474f7 --- /dev/null +++ b/libgfortran/generated/_abs_c10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_10) +#ifdef HAVE_CABSL + +elemental function specific__abs_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: specific__abs_c10 + + specific__abs_c10 = abs (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_abs_c16.F90 b/libgfortran/generated/_abs_c16.F90 new file mode 100644 index 00000000000..acc7f22dfa4 --- /dev/null +++ b/libgfortran/generated/_abs_c16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_16) +#ifdef HAVE_CABSL + +elemental function specific__abs_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: specific__abs_c16 + + specific__abs_c16 = abs (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_abs_c4.f90 b/libgfortran/generated/_abs_c4.F90 index 342dc3d1638..a87fcf6c4a4 100644 --- a/libgfortran/generated/_abs_c4.f90 +++ b/libgfortran/generated/_abs_c4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_4) +#ifdef HAVE_CABSF + elemental function specific__abs_c4 (parm) complex (kind=4), intent (in) :: parm complex (kind=4) :: specific__abs_c4 specific__abs_c4 = abs (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_abs_c8.f90 b/libgfortran/generated/_abs_c8.F90 index e3e18d1b865..294c0027b5d 100644 --- a/libgfortran/generated/_abs_c8.f90 +++ b/libgfortran/generated/_abs_c8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_8) +#ifdef HAVE_CABS + elemental function specific__abs_c8 (parm) complex (kind=8), intent (in) :: parm complex (kind=8) :: specific__abs_c8 specific__abs_c8 = abs (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_abs_i16.F90 b/libgfortran/generated/_abs_i16.F90 new file mode 100644 index 00000000000..afbb67f480e --- /dev/null +++ b/libgfortran/generated/_abs_i16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_16) + + +elemental function specific__abs_i16 (parm) + integer (kind=16), intent (in) :: parm + integer (kind=16) :: specific__abs_i16 + + specific__abs_i16 = abs (parm) +end function + + +#endif diff --git a/libgfortran/generated/_abs_i4.f90 b/libgfortran/generated/_abs_i4.F90 index 97d94a1a7b7..4037d3473ae 100644 --- a/libgfortran/generated/_abs_i4.f90 +++ b/libgfortran/generated/_abs_i4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_4) + + elemental function specific__abs_i4 (parm) integer (kind=4), intent (in) :: parm integer (kind=4) :: specific__abs_i4 specific__abs_i4 = abs (parm) end function + + +#endif diff --git a/libgfortran/generated/_abs_i8.f90 b/libgfortran/generated/_abs_i8.F90 index 909cccfb002..1f2e4244cf9 100644 --- a/libgfortran/generated/_abs_i8.f90 +++ b/libgfortran/generated/_abs_i8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_8) + + elemental function specific__abs_i8 (parm) integer (kind=8), intent (in) :: parm integer (kind=8) :: specific__abs_i8 specific__abs_i8 = abs (parm) end function + + +#endif diff --git a/libgfortran/generated/_abs_r10.F90 b/libgfortran/generated/_abs_r10.F90 new file mode 100644 index 00000000000..4d76a1eafa9 --- /dev/null +++ b/libgfortran/generated/_abs_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_FABSL + +elemental function specific__abs_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__abs_r10 + + specific__abs_r10 = abs (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_abs_r16.F90 b/libgfortran/generated/_abs_r16.F90 new file mode 100644 index 00000000000..3c7d8a74f31 --- /dev/null +++ b/libgfortran/generated/_abs_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_FABSL + +elemental function specific__abs_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__abs_r16 + + specific__abs_r16 = abs (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_abs_r4.f90 b/libgfortran/generated/_abs_r4.F90 index 52a50056af8..31ef426f2ac 100644 --- a/libgfortran/generated/_abs_r4.f90 +++ b/libgfortran/generated/_abs_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_FABSF + elemental function specific__abs_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__abs_r4 specific__abs_r4 = abs (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_abs_r8.f90 b/libgfortran/generated/_abs_r8.F90 index 0f137b626d4..c0b4ce1febe 100644 --- a/libgfortran/generated/_abs_r8.f90 +++ b/libgfortran/generated/_abs_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_FABS + elemental function specific__abs_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__abs_r8 specific__abs_r8 = abs (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_acos_r10.F90 b/libgfortran/generated/_acos_r10.F90 new file mode 100644 index 00000000000..d7be7c8940e --- /dev/null +++ b/libgfortran/generated/_acos_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_ACOSL + +elemental function specific__acos_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__acos_r10 + + specific__acos_r10 = acos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_acos_r16.F90 b/libgfortran/generated/_acos_r16.F90 new file mode 100644 index 00000000000..f0c6dde0863 --- /dev/null +++ b/libgfortran/generated/_acos_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_ACOSL + +elemental function specific__acos_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__acos_r16 + + specific__acos_r16 = acos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_acos_r4.f90 b/libgfortran/generated/_acos_r4.F90 index 8163e387ce3..9e1b97b0e6a 100644 --- a/libgfortran/generated/_acos_r4.f90 +++ b/libgfortran/generated/_acos_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_ACOSF + elemental function specific__acos_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__acos_r4 specific__acos_r4 = acos (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_acos_r8.f90 b/libgfortran/generated/_acos_r8.F90 index d2570911dc2..3bded778503 100644 --- a/libgfortran/generated/_acos_r8.f90 +++ b/libgfortran/generated/_acos_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_ACOS + elemental function specific__acos_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__acos_r8 specific__acos_r8 = acos (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_aint_r10.F90 b/libgfortran/generated/_aint_r10.F90 new file mode 100644 index 00000000000..2448baa53e8 --- /dev/null +++ b/libgfortran/generated/_aint_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_TRUNCL + +elemental function specific__aint_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__aint_r10 + + specific__aint_r10 = aint (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_aint_r16.F90 b/libgfortran/generated/_aint_r16.F90 new file mode 100644 index 00000000000..9903ad4af19 --- /dev/null +++ b/libgfortran/generated/_aint_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_TRUNCL + +elemental function specific__aint_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__aint_r16 + + specific__aint_r16 = aint (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_aint_r4.f90 b/libgfortran/generated/_aint_r4.F90 index a525748c50a..4fb71458834 100644 --- a/libgfortran/generated/_aint_r4.f90 +++ b/libgfortran/generated/_aint_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_TRUNCF + elemental function specific__aint_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__aint_r4 specific__aint_r4 = aint (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_aint_r8.f90 b/libgfortran/generated/_aint_r8.F90 index 0f6e5dd418a..f860c7ae382 100644 --- a/libgfortran/generated/_aint_r8.f90 +++ b/libgfortran/generated/_aint_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_TRUNC + elemental function specific__aint_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__aint_r8 specific__aint_r8 = aint (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_anint_r10.F90 b/libgfortran/generated/_anint_r10.F90 new file mode 100644 index 00000000000..1652417943f --- /dev/null +++ b/libgfortran/generated/_anint_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_ROUNDL + +elemental function specific__anint_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__anint_r10 + + specific__anint_r10 = anint (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_anint_r16.F90 b/libgfortran/generated/_anint_r16.F90 new file mode 100644 index 00000000000..48e1dffb1c3 --- /dev/null +++ b/libgfortran/generated/_anint_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_ROUNDL + +elemental function specific__anint_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__anint_r16 + + specific__anint_r16 = anint (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_anint_r4.f90 b/libgfortran/generated/_anint_r4.F90 index 8b6d62a359a..c1c955ce5e8 100644 --- a/libgfortran/generated/_anint_r4.f90 +++ b/libgfortran/generated/_anint_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_ROUNDF + elemental function specific__anint_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__anint_r4 specific__anint_r4 = anint (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_anint_r8.f90 b/libgfortran/generated/_anint_r8.F90 index 4dc6ab18685..6c72678944d 100644 --- a/libgfortran/generated/_anint_r8.f90 +++ b/libgfortran/generated/_anint_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_ROUND + elemental function specific__anint_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__anint_r8 specific__anint_r8 = anint (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_asin_r10.F90 b/libgfortran/generated/_asin_r10.F90 new file mode 100644 index 00000000000..80939fa3a18 --- /dev/null +++ b/libgfortran/generated/_asin_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_ASINL + +elemental function specific__asin_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__asin_r10 + + specific__asin_r10 = asin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_asin_r16.F90 b/libgfortran/generated/_asin_r16.F90 new file mode 100644 index 00000000000..76e37b6f6a5 --- /dev/null +++ b/libgfortran/generated/_asin_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_ASINL + +elemental function specific__asin_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__asin_r16 + + specific__asin_r16 = asin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_asin_r4.f90 b/libgfortran/generated/_asin_r4.F90 index 907d495e505..cd77113879f 100644 --- a/libgfortran/generated/_asin_r4.f90 +++ b/libgfortran/generated/_asin_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_ASINF + elemental function specific__asin_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__asin_r4 specific__asin_r4 = asin (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_asin_r8.f90 b/libgfortran/generated/_asin_r8.F90 index af035a1b04f..c31f2bc8db3 100644 --- a/libgfortran/generated/_asin_r8.f90 +++ b/libgfortran/generated/_asin_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_ASIN + elemental function specific__asin_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__asin_r8 specific__asin_r8 = asin (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_atan2_r10.F90 b/libgfortran/generated/_atan2_r10.F90 new file mode 100644 index 00000000000..cc9a170bd2d --- /dev/null +++ b/libgfortran/generated/_atan2_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) + +#ifdef HAVE_ATAN2L + +elemental function specific__atan2_r10 (p1, p2) + real (kind=10), intent (in) :: p1, p2 + real (kind=10) :: specific__atan2_r10 + + specific__atan2_r10 = atan2 (p1, p2) +end function + +#endif + +#endif diff --git a/libgfortran/generated/_atan2_r16.F90 b/libgfortran/generated/_atan2_r16.F90 new file mode 100644 index 00000000000..f56aabef8e3 --- /dev/null +++ b/libgfortran/generated/_atan2_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) + +#ifdef HAVE_ATAN2L + +elemental function specific__atan2_r16 (p1, p2) + real (kind=16), intent (in) :: p1, p2 + real (kind=16) :: specific__atan2_r16 + + specific__atan2_r16 = atan2 (p1, p2) +end function + +#endif + +#endif diff --git a/libgfortran/generated/_atan2_r4.f90 b/libgfortran/generated/_atan2_r4.F90 index 92fa2d1b6e8..52ecf7917ba 100644 --- a/libgfortran/generated/_atan2_r4.f90 +++ b/libgfortran/generated/_atan2_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) + +#ifdef HAVE_ATAN2F + elemental function specific__atan2_r4 (p1, p2) real (kind=4), intent (in) :: p1, p2 real (kind=4) :: specific__atan2_r4 specific__atan2_r4 = atan2 (p1, p2) end function + +#endif + +#endif diff --git a/libgfortran/generated/_atan2_r8.f90 b/libgfortran/generated/_atan2_r8.F90 index ef359996a88..752b1653987 100644 --- a/libgfortran/generated/_atan2_r8.f90 +++ b/libgfortran/generated/_atan2_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) + +#ifdef HAVE_ATAN2 + elemental function specific__atan2_r8 (p1, p2) real (kind=8), intent (in) :: p1, p2 real (kind=8) :: specific__atan2_r8 specific__atan2_r8 = atan2 (p1, p2) end function + +#endif + +#endif diff --git a/libgfortran/generated/_atan_r10.F90 b/libgfortran/generated/_atan_r10.F90 new file mode 100644 index 00000000000..195d9414f52 --- /dev/null +++ b/libgfortran/generated/_atan_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_ATANL + +elemental function specific__atan_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__atan_r10 + + specific__atan_r10 = atan (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_atan_r16.F90 b/libgfortran/generated/_atan_r16.F90 new file mode 100644 index 00000000000..2691a34fd37 --- /dev/null +++ b/libgfortran/generated/_atan_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_ATANL + +elemental function specific__atan_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__atan_r16 + + specific__atan_r16 = atan (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_atan_r4.f90 b/libgfortran/generated/_atan_r4.F90 index e3410cfb0fd..4e88ab24f69 100644 --- a/libgfortran/generated/_atan_r4.f90 +++ b/libgfortran/generated/_atan_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_ATANF + elemental function specific__atan_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__atan_r4 specific__atan_r4 = atan (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_atan_r8.f90 b/libgfortran/generated/_atan_r8.F90 index 2e0b75bf2aa..a99de95447b 100644 --- a/libgfortran/generated/_atan_r8.f90 +++ b/libgfortran/generated/_atan_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_ATAN + elemental function specific__atan_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__atan_r8 specific__atan_r8 = atan (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_conjg_c10.F90 b/libgfortran/generated/_conjg_c10.F90 new file mode 100644 index 00000000000..1fa158d283c --- /dev/null +++ b/libgfortran/generated/_conjg_c10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_10) + + +elemental function specific__conjg_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: specific__conjg_c10 + + specific__conjg_c10 = conjg (parm) +end function + + +#endif diff --git a/libgfortran/generated/_conjg_c16.F90 b/libgfortran/generated/_conjg_c16.F90 new file mode 100644 index 00000000000..13c8e147830 --- /dev/null +++ b/libgfortran/generated/_conjg_c16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_16) + + +elemental function specific__conjg_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: specific__conjg_c16 + + specific__conjg_c16 = conjg (parm) +end function + + +#endif diff --git a/libgfortran/generated/_conjg_c4.f90 b/libgfortran/generated/_conjg_c4.F90 index e5904db113e..a4409c94f49 100644 --- a/libgfortran/generated/_conjg_c4.f90 +++ b/libgfortran/generated/_conjg_c4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_4) + + elemental function specific__conjg_c4 (parm) complex (kind=4), intent (in) :: parm complex (kind=4) :: specific__conjg_c4 specific__conjg_c4 = conjg (parm) end function + + +#endif diff --git a/libgfortran/generated/_conjg_c8.f90 b/libgfortran/generated/_conjg_c8.F90 index 5e6d35b5e0e..f1c1254c970 100644 --- a/libgfortran/generated/_conjg_c8.f90 +++ b/libgfortran/generated/_conjg_c8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_8) + + elemental function specific__conjg_c8 (parm) complex (kind=8), intent (in) :: parm complex (kind=8) :: specific__conjg_c8 specific__conjg_c8 = conjg (parm) end function + + +#endif diff --git a/libgfortran/generated/_cos_c10.F90 b/libgfortran/generated/_cos_c10.F90 new file mode 100644 index 00000000000..018394cc919 --- /dev/null +++ b/libgfortran/generated/_cos_c10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_10) +#ifdef HAVE_CCOSL + +elemental function specific__cos_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: specific__cos_c10 + + specific__cos_c10 = cos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cos_c16.F90 b/libgfortran/generated/_cos_c16.F90 new file mode 100644 index 00000000000..ac6bc876862 --- /dev/null +++ b/libgfortran/generated/_cos_c16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_16) +#ifdef HAVE_CCOSL + +elemental function specific__cos_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: specific__cos_c16 + + specific__cos_c16 = cos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cos_c4.f90 b/libgfortran/generated/_cos_c4.F90 index 336f25077c0..e49469577bc 100644 --- a/libgfortran/generated/_cos_c4.f90 +++ b/libgfortran/generated/_cos_c4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_4) +#ifdef HAVE_CCOSF + elemental function specific__cos_c4 (parm) complex (kind=4), intent (in) :: parm complex (kind=4) :: specific__cos_c4 specific__cos_c4 = cos (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_cos_c8.f90 b/libgfortran/generated/_cos_c8.F90 index 68e1c707f23..d3daf6e1360 100644 --- a/libgfortran/generated/_cos_c8.f90 +++ b/libgfortran/generated/_cos_c8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_8) +#ifdef HAVE_CCOS + elemental function specific__cos_c8 (parm) complex (kind=8), intent (in) :: parm complex (kind=8) :: specific__cos_c8 specific__cos_c8 = cos (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_cos_r10.F90 b/libgfortran/generated/_cos_r10.F90 new file mode 100644 index 00000000000..142cb4b947f --- /dev/null +++ b/libgfortran/generated/_cos_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_COSL + +elemental function specific__cos_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__cos_r10 + + specific__cos_r10 = cos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cos_r16.F90 b/libgfortran/generated/_cos_r16.F90 new file mode 100644 index 00000000000..434639755c4 --- /dev/null +++ b/libgfortran/generated/_cos_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_COSL + +elemental function specific__cos_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__cos_r16 + + specific__cos_r16 = cos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cos_r4.f90 b/libgfortran/generated/_cos_r4.F90 index 028c69de1c0..ddf2509a272 100644 --- a/libgfortran/generated/_cos_r4.f90 +++ b/libgfortran/generated/_cos_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_COSF + elemental function specific__cos_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__cos_r4 specific__cos_r4 = cos (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_cos_r8.f90 b/libgfortran/generated/_cos_r8.F90 index 11edb56a61f..d45a11aa33c 100644 --- a/libgfortran/generated/_cos_r8.f90 +++ b/libgfortran/generated/_cos_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_COS + elemental function specific__cos_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__cos_r8 specific__cos_r8 = cos (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_cosh_r10.F90 b/libgfortran/generated/_cosh_r10.F90 new file mode 100644 index 00000000000..9c7d3fbdf88 --- /dev/null +++ b/libgfortran/generated/_cosh_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_COSHL + +elemental function specific__cosh_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__cosh_r10 + + specific__cosh_r10 = cosh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cosh_r16.F90 b/libgfortran/generated/_cosh_r16.F90 new file mode 100644 index 00000000000..ac28f996590 --- /dev/null +++ b/libgfortran/generated/_cosh_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_COSHL + +elemental function specific__cosh_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__cosh_r16 + + specific__cosh_r16 = cosh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cosh_r4.f90 b/libgfortran/generated/_cosh_r4.F90 index 7fab9fc404d..289c9bc0e24 100644 --- a/libgfortran/generated/_cosh_r4.f90 +++ b/libgfortran/generated/_cosh_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_COSHF + elemental function specific__cosh_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__cosh_r4 specific__cosh_r4 = cosh (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_cosh_r8.f90 b/libgfortran/generated/_cosh_r8.F90 index 855ee485c5e..6b47452298c 100644 --- a/libgfortran/generated/_cosh_r8.f90 +++ b/libgfortran/generated/_cosh_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_COSH + elemental function specific__cosh_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__cosh_r8 specific__cosh_r8 = cosh (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_dim_i16.F90 b/libgfortran/generated/_dim_i16.F90 new file mode 100644 index 00000000000..55a1a521a88 --- /dev/null +++ b/libgfortran/generated/_dim_i16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_16) + + + +elemental function specific__dim_i16 (p1, p2) + integer (kind=16), intent (in) :: p1, p2 + integer (kind=16) :: specific__dim_i16 + + specific__dim_i16 = dim (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_dim_i4.f90 b/libgfortran/generated/_dim_i4.F90 index 4396c66bcc0..2fd8658460a 100644 --- a/libgfortran/generated/_dim_i4.f90 +++ b/libgfortran/generated/_dim_i4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_4) + + + elemental function specific__dim_i4 (p1, p2) integer (kind=4), intent (in) :: p1, p2 integer (kind=4) :: specific__dim_i4 specific__dim_i4 = dim (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_dim_i8.f90 b/libgfortran/generated/_dim_i8.F90 index 0584d1a3a45..e861d9eb841 100644 --- a/libgfortran/generated/_dim_i8.f90 +++ b/libgfortran/generated/_dim_i8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_8) + + + elemental function specific__dim_i8 (p1, p2) integer (kind=8), intent (in) :: p1, p2 integer (kind=8) :: specific__dim_i8 specific__dim_i8 = dim (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_dim_r10.F90 b/libgfortran/generated/_dim_r10.F90 new file mode 100644 index 00000000000..1e7743d6671 --- /dev/null +++ b/libgfortran/generated/_dim_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) + + + +elemental function specific__dim_r10 (p1, p2) + real (kind=10), intent (in) :: p1, p2 + real (kind=10) :: specific__dim_r10 + + specific__dim_r10 = dim (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_dim_r16.F90 b/libgfortran/generated/_dim_r16.F90 new file mode 100644 index 00000000000..97a048890e3 --- /dev/null +++ b/libgfortran/generated/_dim_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) + + + +elemental function specific__dim_r16 (p1, p2) + real (kind=16), intent (in) :: p1, p2 + real (kind=16) :: specific__dim_r16 + + specific__dim_r16 = dim (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_dim_r4.f90 b/libgfortran/generated/_dim_r4.F90 index 7fd1bc5dc85..465b28489aa 100644 --- a/libgfortran/generated/_dim_r4.f90 +++ b/libgfortran/generated/_dim_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) + + + elemental function specific__dim_r4 (p1, p2) real (kind=4), intent (in) :: p1, p2 real (kind=4) :: specific__dim_r4 specific__dim_r4 = dim (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_dim_r8.f90 b/libgfortran/generated/_dim_r8.F90 index 3e43f11f1f6..3e6b3379fe2 100644 --- a/libgfortran/generated/_dim_r8.f90 +++ b/libgfortran/generated/_dim_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) + + + elemental function specific__dim_r8 (p1, p2) real (kind=8), intent (in) :: p1, p2 real (kind=8) :: specific__dim_r8 specific__dim_r8 = dim (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_exp_c10.F90 b/libgfortran/generated/_exp_c10.F90 new file mode 100644 index 00000000000..bcf1f2bdd87 --- /dev/null +++ b/libgfortran/generated/_exp_c10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_10) +#ifdef HAVE_CEXPL + +elemental function specific__exp_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: specific__exp_c10 + + specific__exp_c10 = exp (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_exp_c16.F90 b/libgfortran/generated/_exp_c16.F90 new file mode 100644 index 00000000000..58527bc536a --- /dev/null +++ b/libgfortran/generated/_exp_c16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_16) +#ifdef HAVE_CEXPL + +elemental function specific__exp_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: specific__exp_c16 + + specific__exp_c16 = exp (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_exp_c4.f90 b/libgfortran/generated/_exp_c4.F90 index 28044eb75da..6fba6756be9 100644 --- a/libgfortran/generated/_exp_c4.f90 +++ b/libgfortran/generated/_exp_c4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_4) +#ifdef HAVE_CEXPF + elemental function specific__exp_c4 (parm) complex (kind=4), intent (in) :: parm complex (kind=4) :: specific__exp_c4 specific__exp_c4 = exp (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_exp_c8.f90 b/libgfortran/generated/_exp_c8.F90 index 17f15375f0c..cbc82a156dd 100644 --- a/libgfortran/generated/_exp_c8.f90 +++ b/libgfortran/generated/_exp_c8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_8) +#ifdef HAVE_CEXP + elemental function specific__exp_c8 (parm) complex (kind=8), intent (in) :: parm complex (kind=8) :: specific__exp_c8 specific__exp_c8 = exp (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_exp_r10.F90 b/libgfortran/generated/_exp_r10.F90 new file mode 100644 index 00000000000..86bf749943a --- /dev/null +++ b/libgfortran/generated/_exp_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_EXPL + +elemental function specific__exp_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__exp_r10 + + specific__exp_r10 = exp (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_exp_r16.F90 b/libgfortran/generated/_exp_r16.F90 new file mode 100644 index 00000000000..4aaee9eb17d --- /dev/null +++ b/libgfortran/generated/_exp_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_EXPL + +elemental function specific__exp_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__exp_r16 + + specific__exp_r16 = exp (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_exp_r4.f90 b/libgfortran/generated/_exp_r4.F90 index 261f6a08489..d76fb143cc6 100644 --- a/libgfortran/generated/_exp_r4.f90 +++ b/libgfortran/generated/_exp_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_EXPF + elemental function specific__exp_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__exp_r4 specific__exp_r4 = exp (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_exp_r8.f90 b/libgfortran/generated/_exp_r8.F90 index f525b413a1b..d529810ca57 100644 --- a/libgfortran/generated/_exp_r8.f90 +++ b/libgfortran/generated/_exp_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_EXP + elemental function specific__exp_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__exp_r8 specific__exp_r8 = exp (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_log10_r10.F90 b/libgfortran/generated/_log10_r10.F90 new file mode 100644 index 00000000000..19aeac5c1be --- /dev/null +++ b/libgfortran/generated/_log10_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_LOG10L + +elemental function specific__log10_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__log10_r10 + + specific__log10_r10 = log10 (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log10_r16.F90 b/libgfortran/generated/_log10_r16.F90 new file mode 100644 index 00000000000..c03002aa456 --- /dev/null +++ b/libgfortran/generated/_log10_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_LOG10L + +elemental function specific__log10_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__log10_r16 + + specific__log10_r16 = log10 (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log10_r4.f90 b/libgfortran/generated/_log10_r4.F90 index 712d56b4aae..c772527ae86 100644 --- a/libgfortran/generated/_log10_r4.f90 +++ b/libgfortran/generated/_log10_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_LOG10F + elemental function specific__log10_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__log10_r4 specific__log10_r4 = log10 (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_log10_r8.f90 b/libgfortran/generated/_log10_r8.F90 index 7c3f63de5e1..396570989e6 100644 --- a/libgfortran/generated/_log10_r8.f90 +++ b/libgfortran/generated/_log10_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_LOG10 + elemental function specific__log10_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__log10_r8 specific__log10_r8 = log10 (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_log_c10.F90 b/libgfortran/generated/_log_c10.F90 new file mode 100644 index 00000000000..e3f6934e628 --- /dev/null +++ b/libgfortran/generated/_log_c10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_10) +#ifdef HAVE_CLOGL + +elemental function specific__log_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: specific__log_c10 + + specific__log_c10 = log (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log_c16.F90 b/libgfortran/generated/_log_c16.F90 new file mode 100644 index 00000000000..776140a7e78 --- /dev/null +++ b/libgfortran/generated/_log_c16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_16) +#ifdef HAVE_CLOGL + +elemental function specific__log_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: specific__log_c16 + + specific__log_c16 = log (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log_c4.f90 b/libgfortran/generated/_log_c4.F90 index 7f83e527f26..923bdd573ca 100644 --- a/libgfortran/generated/_log_c4.f90 +++ b/libgfortran/generated/_log_c4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_4) +#ifdef HAVE_CLOGF + elemental function specific__log_c4 (parm) complex (kind=4), intent (in) :: parm complex (kind=4) :: specific__log_c4 specific__log_c4 = log (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_log_c8.f90 b/libgfortran/generated/_log_c8.F90 index 92b267be0a9..0df0dd83d2d 100644 --- a/libgfortran/generated/_log_c8.f90 +++ b/libgfortran/generated/_log_c8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_8) +#ifdef HAVE_CLOG + elemental function specific__log_c8 (parm) complex (kind=8), intent (in) :: parm complex (kind=8) :: specific__log_c8 specific__log_c8 = log (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_log_r10.F90 b/libgfortran/generated/_log_r10.F90 new file mode 100644 index 00000000000..d8938818053 --- /dev/null +++ b/libgfortran/generated/_log_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_LOGL + +elemental function specific__log_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__log_r10 + + specific__log_r10 = log (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log_r16.F90 b/libgfortran/generated/_log_r16.F90 new file mode 100644 index 00000000000..5013656e9da --- /dev/null +++ b/libgfortran/generated/_log_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_LOGL + +elemental function specific__log_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__log_r16 + + specific__log_r16 = log (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log_r4.f90 b/libgfortran/generated/_log_r4.F90 index 6e667a02718..6a742377648 100644 --- a/libgfortran/generated/_log_r4.f90 +++ b/libgfortran/generated/_log_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_LOGF + elemental function specific__log_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__log_r4 specific__log_r4 = log (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_log_r8.f90 b/libgfortran/generated/_log_r8.F90 index 38a86283504..8383bbfd36a 100644 --- a/libgfortran/generated/_log_r8.f90 +++ b/libgfortran/generated/_log_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_LOG + elemental function specific__log_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__log_r8 specific__log_r8 = log (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_mod_i16.F90 b/libgfortran/generated/_mod_i16.F90 new file mode 100644 index 00000000000..571db409bf9 --- /dev/null +++ b/libgfortran/generated/_mod_i16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_16) + + + +elemental function specific__mod_i16 (p1, p2) + integer (kind=16), intent (in) :: p1, p2 + integer (kind=16) :: specific__mod_i16 + + specific__mod_i16 = mod (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_mod_i4.f90 b/libgfortran/generated/_mod_i4.F90 index 3776e05c4d8..ec6f81dee2a 100644 --- a/libgfortran/generated/_mod_i4.f90 +++ b/libgfortran/generated/_mod_i4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_4) + + + elemental function specific__mod_i4 (p1, p2) integer (kind=4), intent (in) :: p1, p2 integer (kind=4) :: specific__mod_i4 specific__mod_i4 = mod (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_mod_i8.f90 b/libgfortran/generated/_mod_i8.F90 index 4dd2b52d2c9..e34278b13ec 100644 --- a/libgfortran/generated/_mod_i8.f90 +++ b/libgfortran/generated/_mod_i8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_8) + + + elemental function specific__mod_i8 (p1, p2) integer (kind=8), intent (in) :: p1, p2 integer (kind=8) :: specific__mod_i8 specific__mod_i8 = mod (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_mod_r4.f90 b/libgfortran/generated/_mod_r4.F90 index 20fb128f1cc..6742ee488af 100644 --- a/libgfortran/generated/_mod_r4.f90 +++ b/libgfortran/generated/_mod_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) + + + elemental function specific__mod_r4 (p1, p2) real (kind=4), intent (in) :: p1, p2 real (kind=4) :: specific__mod_r4 specific__mod_r4 = mod (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_mod_r8.f90 b/libgfortran/generated/_mod_r8.F90 index 25b90d4df25..3cc7e165111 100644 --- a/libgfortran/generated/_mod_r8.f90 +++ b/libgfortran/generated/_mod_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) + + + elemental function specific__mod_r8 (p1, p2) real (kind=8), intent (in) :: p1, p2 real (kind=8) :: specific__mod_r8 specific__mod_r8 = mod (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_sign_i16.F90 b/libgfortran/generated/_sign_i16.F90 new file mode 100644 index 00000000000..50e492c3f80 --- /dev/null +++ b/libgfortran/generated/_sign_i16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_16) + + + +elemental function specific__sign_i16 (p1, p2) + integer (kind=16), intent (in) :: p1, p2 + integer (kind=16) :: specific__sign_i16 + + specific__sign_i16 = sign (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_sign_i4.f90 b/libgfortran/generated/_sign_i4.F90 index 420318876c2..d9ea551c6d9 100644 --- a/libgfortran/generated/_sign_i4.f90 +++ b/libgfortran/generated/_sign_i4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_4) + + + elemental function specific__sign_i4 (p1, p2) integer (kind=4), intent (in) :: p1, p2 integer (kind=4) :: specific__sign_i4 specific__sign_i4 = sign (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_sign_i8.f90 b/libgfortran/generated/_sign_i8.F90 index e3cd674cbb9..241fb8b0f1c 100644 --- a/libgfortran/generated/_sign_i8.f90 +++ b/libgfortran/generated/_sign_i8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_8) + + + elemental function specific__sign_i8 (p1, p2) integer (kind=8), intent (in) :: p1, p2 integer (kind=8) :: specific__sign_i8 specific__sign_i8 = sign (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_sign_r10.F90 b/libgfortran/generated/_sign_r10.F90 new file mode 100644 index 00000000000..002330f0d80 --- /dev/null +++ b/libgfortran/generated/_sign_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) + + + +elemental function specific__sign_r10 (p1, p2) + real (kind=10), intent (in) :: p1, p2 + real (kind=10) :: specific__sign_r10 + + specific__sign_r10 = sign (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_sign_r16.F90 b/libgfortran/generated/_sign_r16.F90 new file mode 100644 index 00000000000..8377969c67a --- /dev/null +++ b/libgfortran/generated/_sign_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) + + + +elemental function specific__sign_r16 (p1, p2) + real (kind=16), intent (in) :: p1, p2 + real (kind=16) :: specific__sign_r16 + + specific__sign_r16 = sign (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_sign_r4.f90 b/libgfortran/generated/_sign_r4.F90 index f5fef6a2031..e11f15d093e 100644 --- a/libgfortran/generated/_sign_r4.f90 +++ b/libgfortran/generated/_sign_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) + + + elemental function specific__sign_r4 (p1, p2) real (kind=4), intent (in) :: p1, p2 real (kind=4) :: specific__sign_r4 specific__sign_r4 = sign (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_sign_r8.f90 b/libgfortran/generated/_sign_r8.F90 index b676205d187..66f8dee53a5 100644 --- a/libgfortran/generated/_sign_r8.f90 +++ b/libgfortran/generated/_sign_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) + + + elemental function specific__sign_r8 (p1, p2) real (kind=8), intent (in) :: p1, p2 real (kind=8) :: specific__sign_r8 specific__sign_r8 = sign (p1, p2) end function + + + +#endif diff --git a/libgfortran/generated/_sin_c10.F90 b/libgfortran/generated/_sin_c10.F90 new file mode 100644 index 00000000000..2c34b3c931d --- /dev/null +++ b/libgfortran/generated/_sin_c10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_10) +#ifdef HAVE_CSINL + +elemental function specific__sin_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: specific__sin_c10 + + specific__sin_c10 = sin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sin_c16.F90 b/libgfortran/generated/_sin_c16.F90 new file mode 100644 index 00000000000..75a7108795f --- /dev/null +++ b/libgfortran/generated/_sin_c16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_16) +#ifdef HAVE_CSINL + +elemental function specific__sin_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: specific__sin_c16 + + specific__sin_c16 = sin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sin_c4.f90 b/libgfortran/generated/_sin_c4.F90 index 059bd943981..0efc127d87f 100644 --- a/libgfortran/generated/_sin_c4.f90 +++ b/libgfortran/generated/_sin_c4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_4) +#ifdef HAVE_CSINF + elemental function specific__sin_c4 (parm) complex (kind=4), intent (in) :: parm complex (kind=4) :: specific__sin_c4 specific__sin_c4 = sin (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_sin_c8.f90 b/libgfortran/generated/_sin_c8.F90 index 56c4cfa3895..73a27a42e69 100644 --- a/libgfortran/generated/_sin_c8.f90 +++ b/libgfortran/generated/_sin_c8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_8) +#ifdef HAVE_CSIN + elemental function specific__sin_c8 (parm) complex (kind=8), intent (in) :: parm complex (kind=8) :: specific__sin_c8 specific__sin_c8 = sin (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_sin_r10.F90 b/libgfortran/generated/_sin_r10.F90 new file mode 100644 index 00000000000..55f5871fc3d --- /dev/null +++ b/libgfortran/generated/_sin_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_SINL + +elemental function specific__sin_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__sin_r10 + + specific__sin_r10 = sin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sin_r16.F90 b/libgfortran/generated/_sin_r16.F90 new file mode 100644 index 00000000000..3757cc0b1f8 --- /dev/null +++ b/libgfortran/generated/_sin_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_SINL + +elemental function specific__sin_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__sin_r16 + + specific__sin_r16 = sin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sin_r4.f90 b/libgfortran/generated/_sin_r4.F90 index 4520ad7d9ef..4fea10356e9 100644 --- a/libgfortran/generated/_sin_r4.f90 +++ b/libgfortran/generated/_sin_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_SINF + elemental function specific__sin_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__sin_r4 specific__sin_r4 = sin (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_sin_r8.f90 b/libgfortran/generated/_sin_r8.F90 index 20dd269fef1..e35c3d1c254 100644 --- a/libgfortran/generated/_sin_r8.f90 +++ b/libgfortran/generated/_sin_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_SIN + elemental function specific__sin_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__sin_r8 specific__sin_r8 = sin (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_sinh_r10.F90 b/libgfortran/generated/_sinh_r10.F90 new file mode 100644 index 00000000000..7aa5e98a2f3 --- /dev/null +++ b/libgfortran/generated/_sinh_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_SINHL + +elemental function specific__sinh_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__sinh_r10 + + specific__sinh_r10 = sinh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sinh_r16.F90 b/libgfortran/generated/_sinh_r16.F90 new file mode 100644 index 00000000000..6ea69470788 --- /dev/null +++ b/libgfortran/generated/_sinh_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_SINHL + +elemental function specific__sinh_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__sinh_r16 + + specific__sinh_r16 = sinh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sinh_r4.f90 b/libgfortran/generated/_sinh_r4.F90 index 545d0aa5ded..1101debe902 100644 --- a/libgfortran/generated/_sinh_r4.f90 +++ b/libgfortran/generated/_sinh_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_SINHF + elemental function specific__sinh_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__sinh_r4 specific__sinh_r4 = sinh (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_sinh_r8.f90 b/libgfortran/generated/_sinh_r8.F90 index b3788390148..63eb8d5c246 100644 --- a/libgfortran/generated/_sinh_r8.f90 +++ b/libgfortran/generated/_sinh_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_SINH + elemental function specific__sinh_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__sinh_r8 specific__sinh_r8 = sinh (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_c10.F90 b/libgfortran/generated/_sqrt_c10.F90 new file mode 100644 index 00000000000..2159a6b93aa --- /dev/null +++ b/libgfortran/generated/_sqrt_c10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_10) +#ifdef HAVE_CSQRTL + +elemental function specific__sqrt_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: specific__sqrt_c10 + + specific__sqrt_c10 = sqrt (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_c16.F90 b/libgfortran/generated/_sqrt_c16.F90 new file mode 100644 index 00000000000..2ee9c83a1bb --- /dev/null +++ b/libgfortran/generated/_sqrt_c16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_16) +#ifdef HAVE_CSQRTL + +elemental function specific__sqrt_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: specific__sqrt_c16 + + specific__sqrt_c16 = sqrt (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_c4.f90 b/libgfortran/generated/_sqrt_c4.F90 index 901f2d7e5c1..1e88a3d6e5d 100644 --- a/libgfortran/generated/_sqrt_c4.f90 +++ b/libgfortran/generated/_sqrt_c4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_4) +#ifdef HAVE_CSQRTF + elemental function specific__sqrt_c4 (parm) complex (kind=4), intent (in) :: parm complex (kind=4) :: specific__sqrt_c4 specific__sqrt_c4 = sqrt (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_c8.f90 b/libgfortran/generated/_sqrt_c8.F90 index 023620f3285..edd5e399b0b 100644 --- a/libgfortran/generated/_sqrt_c8.f90 +++ b/libgfortran/generated/_sqrt_c8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_8) +#ifdef HAVE_CSQRT + elemental function specific__sqrt_c8 (parm) complex (kind=8), intent (in) :: parm complex (kind=8) :: specific__sqrt_c8 specific__sqrt_c8 = sqrt (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_r10.F90 b/libgfortran/generated/_sqrt_r10.F90 new file mode 100644 index 00000000000..2ea81ba56cb --- /dev/null +++ b/libgfortran/generated/_sqrt_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_SQRTL + +elemental function specific__sqrt_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__sqrt_r10 + + specific__sqrt_r10 = sqrt (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_r16.F90 b/libgfortran/generated/_sqrt_r16.F90 new file mode 100644 index 00000000000..5ecd027bd1b --- /dev/null +++ b/libgfortran/generated/_sqrt_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_SQRTL + +elemental function specific__sqrt_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__sqrt_r16 + + specific__sqrt_r16 = sqrt (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_r4.f90 b/libgfortran/generated/_sqrt_r4.F90 index d55cfa723df..43c710f0dd2 100644 --- a/libgfortran/generated/_sqrt_r4.f90 +++ b/libgfortran/generated/_sqrt_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_SQRTF + elemental function specific__sqrt_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__sqrt_r4 specific__sqrt_r4 = sqrt (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_r8.f90 b/libgfortran/generated/_sqrt_r8.F90 index 28c1d5db127..2f710962b8f 100644 --- a/libgfortran/generated/_sqrt_r8.f90 +++ b/libgfortran/generated/_sqrt_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_SQRT + elemental function specific__sqrt_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__sqrt_r8 specific__sqrt_r8 = sqrt (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_tan_r10.F90 b/libgfortran/generated/_tan_r10.F90 new file mode 100644 index 00000000000..d4c06ae4a86 --- /dev/null +++ b/libgfortran/generated/_tan_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_TANL + +elemental function specific__tan_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__tan_r10 + + specific__tan_r10 = tan (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_tan_r16.F90 b/libgfortran/generated/_tan_r16.F90 new file mode 100644 index 00000000000..5a6f61a3f9d --- /dev/null +++ b/libgfortran/generated/_tan_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_TANL + +elemental function specific__tan_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__tan_r16 + + specific__tan_r16 = tan (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_tan_r4.f90 b/libgfortran/generated/_tan_r4.F90 index 7e0fd557881..ee8f438d7e2 100644 --- a/libgfortran/generated/_tan_r4.f90 +++ b/libgfortran/generated/_tan_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_TANF + elemental function specific__tan_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__tan_r4 specific__tan_r4 = tan (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_tan_r8.f90 b/libgfortran/generated/_tan_r8.F90 index 5a8716ea1b6..f2e357b2dd1 100644 --- a/libgfortran/generated/_tan_r8.f90 +++ b/libgfortran/generated/_tan_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_TAN + elemental function specific__tan_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__tan_r8 specific__tan_r8 = tan (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_tanh_r10.F90 b/libgfortran/generated/_tanh_r10.F90 new file mode 100644 index 00000000000..5d04f65475d --- /dev/null +++ b/libgfortran/generated/_tanh_r10.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_TANHL + +elemental function specific__tanh_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: specific__tanh_r10 + + specific__tanh_r10 = tanh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_tanh_r16.F90 b/libgfortran/generated/_tanh_r16.F90 new file mode 100644 index 00000000000..9a858b5c071 --- /dev/null +++ b/libgfortran/generated/_tanh_r16.F90 @@ -0,0 +1,51 @@ +! Copyright 2002 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran is free software; you can redistribute it and/or +!modify it under the terms of the GNU General Public +!License as published by the Free Software Foundation; either +!version 2 of the License, or (at your option) any later version. + +!In addition to the permissions in the GNU General Public License, the +!Free Software Foundation gives you unlimited permission to link the +!compiled version of this file into combinations with other programs, +!and to distribute those combinations without any restriction coming +!from the use of this file. (The General Public License restrictions +!do apply in other respects; for example, they cover modification of +!the file, and distribution when not linked into a combine +!executable.) +! +!GNU libgfortran is distributed in the hope that it will be useful, +!but WITHOUT ANY WARRANTY; without even the implied warranty of +!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +!GNU General Public License for more details. +! +!You should have received a copy of the GNU General Public +!License along with libgfortran; see the file COPYING. If not, +!write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +!Boston, MA 02110-1301, USA. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_TANHL + +elemental function specific__tanh_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: specific__tanh_r16 + + specific__tanh_r16 = tanh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_tanh_r4.f90 b/libgfortran/generated/_tanh_r4.F90 index 0f3174b468a..0872fe66540 100644 --- a/libgfortran/generated/_tanh_r4.f90 +++ b/libgfortran/generated/_tanh_r4.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_TANHF + elemental function specific__tanh_r4 (parm) real (kind=4), intent (in) :: parm real (kind=4) :: specific__tanh_r4 specific__tanh_r4 = tanh (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/_tanh_r8.f90 b/libgfortran/generated/_tanh_r8.F90 index 9d6ed774f05..40a6668e403 100644 --- a/libgfortran/generated/_tanh_r8.f90 +++ b/libgfortran/generated/_tanh_r8.F90 @@ -30,9 +30,22 @@ !This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_TANH + elemental function specific__tanh_r8 (parm) real (kind=8), intent (in) :: parm real (kind=8) :: specific__tanh_r8 specific__tanh_r8 = tanh (parm) end function + +#endif +#endif diff --git a/libgfortran/generated/all_l16.c b/libgfortran/generated/all_l16.c new file mode 100644 index 00000000000..40851eb2c19 --- /dev/null +++ b/libgfortran/generated/all_l16.c @@ -0,0 +1,177 @@ +/* Implementation of the ALL intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_LOGICAL_16) + + +extern void all_l16 (gfc_array_l16 *, gfc_array_l16 *, index_type *); +export_proto(all_l16); + +void +all_l16 (gfc_array_l16 *retarray, gfc_array_l16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_LOGICAL_16 *base; + GFC_LOGICAL_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_LOGICAL_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_LOGICAL_16 *src; + GFC_LOGICAL_16 result; + src = base; + { + + /* Return true only if all the elements are set. */ + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (! *src) + { + result = 0; + break; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/all_l4.c b/libgfortran/generated/all_l4.c index 82035f19cbe..246ec07a507 100644 --- a/libgfortran/generated/all_l4.c +++ b/libgfortran/generated/all_l4.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_LOGICAL_4) + + extern void all_l4 (gfc_array_l4 *, gfc_array_l4 *, index_type *); export_proto(all_l4); @@ -171,3 +174,4 @@ all_l4 (gfc_array_l4 *retarray, gfc_array_l4 *array, index_type *pdim) } } +#endif diff --git a/libgfortran/generated/all_l8.c b/libgfortran/generated/all_l8.c index 41552d21e67..996ce3560bf 100644 --- a/libgfortran/generated/all_l8.c +++ b/libgfortran/generated/all_l8.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_LOGICAL_8) + + extern void all_l8 (gfc_array_l8 *, gfc_array_l8 *, index_type *); export_proto(all_l8); @@ -171,3 +174,4 @@ all_l8 (gfc_array_l8 *retarray, gfc_array_l8 *array, index_type *pdim) } } +#endif diff --git a/libgfortran/generated/any_l16.c b/libgfortran/generated/any_l16.c new file mode 100644 index 00000000000..cf4798e7962 --- /dev/null +++ b/libgfortran/generated/any_l16.c @@ -0,0 +1,177 @@ +/* Implementation of the ANY intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_LOGICAL_16) + + +extern void any_l16 (gfc_array_l16 *, gfc_array_l16 *, index_type *); +export_proto(any_l16); + +void +any_l16 (gfc_array_l16 *retarray, gfc_array_l16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_LOGICAL_16 *base; + GFC_LOGICAL_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_LOGICAL_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_LOGICAL_16 *src; + GFC_LOGICAL_16 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + /* Return true if any of the elements are set. */ + if (*src) + { + result = 1; + break; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/any_l4.c b/libgfortran/generated/any_l4.c index 4d3153e4243..994014a2cac 100644 --- a/libgfortran/generated/any_l4.c +++ b/libgfortran/generated/any_l4.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_LOGICAL_4) + + extern void any_l4 (gfc_array_l4 *, gfc_array_l4 *, index_type *); export_proto(any_l4); @@ -171,3 +174,4 @@ any_l4 (gfc_array_l4 *retarray, gfc_array_l4 *array, index_type *pdim) } } +#endif diff --git a/libgfortran/generated/any_l8.c b/libgfortran/generated/any_l8.c index 29fdcd13d78..9d52b15c509 100644 --- a/libgfortran/generated/any_l8.c +++ b/libgfortran/generated/any_l8.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_LOGICAL_8) + + extern void any_l8 (gfc_array_l8 *, gfc_array_l8 *, index_type *); export_proto(any_l8); @@ -171,3 +174,4 @@ any_l8 (gfc_array_l8 *retarray, gfc_array_l8 *array, index_type *pdim) } } +#endif diff --git a/libgfortran/generated/count_16_l16.c b/libgfortran/generated/count_16_l16.c new file mode 100644 index 00000000000..8cb795faf5e --- /dev/null +++ b/libgfortran/generated/count_16_l16.c @@ -0,0 +1,173 @@ +/* Implementation of the COUNT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void count_16_l16 (gfc_array_i16 *, gfc_array_l16 *, index_type *); +export_proto(count_16_l16); + +void +count_16_l16 (gfc_array_i16 *retarray, gfc_array_l16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_LOGICAL_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_LOGICAL_16 *src; + GFC_INTEGER_16 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src) + result++; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/count_16_l4.c b/libgfortran/generated/count_16_l4.c new file mode 100644 index 00000000000..f4af5ba3152 --- /dev/null +++ b/libgfortran/generated/count_16_l4.c @@ -0,0 +1,173 @@ +/* Implementation of the COUNT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void count_16_l4 (gfc_array_i16 *, gfc_array_l4 *, index_type *); +export_proto(count_16_l4); + +void +count_16_l4 (gfc_array_i16 *retarray, gfc_array_l4 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_LOGICAL_4 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_LOGICAL_4 *src; + GFC_INTEGER_16 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src) + result++; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/count_16_l8.c b/libgfortran/generated/count_16_l8.c new file mode 100644 index 00000000000..6134f5b13c6 --- /dev/null +++ b/libgfortran/generated/count_16_l8.c @@ -0,0 +1,173 @@ +/* Implementation of the COUNT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void count_16_l8 (gfc_array_i16 *, gfc_array_l8 *, index_type *); +export_proto(count_16_l8); + +void +count_16_l8 (gfc_array_i16 *retarray, gfc_array_l8 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_LOGICAL_8 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_LOGICAL_8 *src; + GFC_INTEGER_16 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src) + result++; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/count_4_l16.c b/libgfortran/generated/count_4_l16.c new file mode 100644 index 00000000000..cbd1717df25 --- /dev/null +++ b/libgfortran/generated/count_4_l16.c @@ -0,0 +1,173 @@ +/* Implementation of the COUNT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void count_4_l16 (gfc_array_i4 *, gfc_array_l16 *, index_type *); +export_proto(count_4_l16); + +void +count_4_l16 (gfc_array_i4 *retarray, gfc_array_l16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_LOGICAL_16 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_LOGICAL_16 *src; + GFC_INTEGER_4 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src) + result++; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/count_4_l4.c b/libgfortran/generated/count_4_l4.c index c2fdbf0b394..aa98bfc66c1 100644 --- a/libgfortran/generated/count_4_l4.c +++ b/libgfortran/generated/count_4_l4.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_4) + + extern void count_4_l4 (gfc_array_i4 *, gfc_array_l4 *, index_type *); export_proto(count_4_l4); @@ -167,3 +170,4 @@ count_4_l4 (gfc_array_i4 *retarray, gfc_array_l4 *array, index_type *pdim) } } +#endif diff --git a/libgfortran/generated/count_4_l8.c b/libgfortran/generated/count_4_l8.c index 473483a12f2..fe9eae530cf 100644 --- a/libgfortran/generated/count_4_l8.c +++ b/libgfortran/generated/count_4_l8.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_4) + + extern void count_4_l8 (gfc_array_i4 *, gfc_array_l8 *, index_type *); export_proto(count_4_l8); @@ -167,3 +170,4 @@ count_4_l8 (gfc_array_i4 *retarray, gfc_array_l8 *array, index_type *pdim) } } +#endif diff --git a/libgfortran/generated/count_8_l16.c b/libgfortran/generated/count_8_l16.c new file mode 100644 index 00000000000..4df2aeb8214 --- /dev/null +++ b/libgfortran/generated/count_8_l16.c @@ -0,0 +1,173 @@ +/* Implementation of the COUNT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void count_8_l16 (gfc_array_i8 *, gfc_array_l16 *, index_type *); +export_proto(count_8_l16); + +void +count_8_l16 (gfc_array_i8 *retarray, gfc_array_l16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_LOGICAL_16 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_LOGICAL_16 *src; + GFC_INTEGER_8 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src) + result++; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/count_8_l4.c b/libgfortran/generated/count_8_l4.c index 595cb40a5a9..b32b30e173a 100644 --- a/libgfortran/generated/count_8_l4.c +++ b/libgfortran/generated/count_8_l4.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_8) + + extern void count_8_l4 (gfc_array_i8 *, gfc_array_l4 *, index_type *); export_proto(count_8_l4); @@ -167,3 +170,4 @@ count_8_l4 (gfc_array_i8 *retarray, gfc_array_l4 *array, index_type *pdim) } } +#endif diff --git a/libgfortran/generated/count_8_l8.c b/libgfortran/generated/count_8_l8.c index 1e9bd619f2a..670fc1d1cf1 100644 --- a/libgfortran/generated/count_8_l8.c +++ b/libgfortran/generated/count_8_l8.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_8) + + extern void count_8_l8 (gfc_array_i8 *, gfc_array_l8 *, index_type *); export_proto(count_8_l8); @@ -167,3 +170,4 @@ count_8_l8 (gfc_array_i8 *retarray, gfc_array_l8 *array, index_type *pdim) } } +#endif diff --git a/libgfortran/generated/cshift1_16.c b/libgfortran/generated/cshift1_16.c new file mode 100644 index 00000000000..bff20d3b4be --- /dev/null +++ b/libgfortran/generated/cshift1_16.c @@ -0,0 +1,225 @@ +/* Implementation of the CSHIFT intrinsic + Copyright 2003 Free Software Foundation, Inc. + Contributed by Feng Wang <wf_cs@yahoo.com> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_INTEGER_16) + +static void +cshift1 (gfc_array_char * ret, const gfc_array_char * array, + const gfc_array_i16 * h, const GFC_INTEGER_16 * pwhich, index_type size) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char *rptr; + char *dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const char *sptr; + const char *src; + /* h.* indicates the array. */ + index_type hstride[GFC_MAX_DIMENSIONS]; + index_type hstride0; + const GFC_INTEGER_16 *hptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + int which; + GFC_INTEGER_16 sh; + + if (pwhich) + which = *pwhich - 1; + else + which = 0; + + if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array)) + runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'"); + + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + + extent[0] = 1; + count[0] = 0; + n = 0; + + /* Initialized for avoiding compiler warnings. */ + roffset = size; + soffset = size; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = ret->dim[dim].stride * size; + if (roffset == 0) + roffset = size; + soffset = array->dim[dim].stride * size; + if (soffset == 0) + soffset = size; + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + } + else + { + count[n] = 0; + extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + rstride[n] = ret->dim[dim].stride * size; + sstride[n] = array->dim[dim].stride * size; + + hstride[n] = h->dim[n].stride; + n++; + } + } + if (sstride[0] == 0) + sstride[0] = size; + if (rstride[0] == 0) + rstride[0] = size; + if (hstride[0] == 0) + hstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + hstride0 = hstride[0]; + rptr = ret->data; + sptr = array->data; + hptr = h->data; + + while (rptr) + { + /* Do the for this dimension. */ + sh = *hptr; + sh = (div (sh, len)).rem; + if (sh < 0) + sh += len; + + src = &sptr[sh * soffset]; + dest = rptr; + + for (n = 0; n < len; n++) + { + memcpy (dest, src, size); + dest += roffset; + if (n == len - sh - 1) + src = sptr; + else + src += soffset; + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + hptr += hstride0; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[n] * extent[n]; + hptr -= hstride[n] * extent[n]; + n++; + if (n >= dim - 1) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + sptr += sstride[n]; + hptr += hstride[n]; + } + } + } +} + +void cshift1_16 (gfc_array_char *, const gfc_array_char *, + const gfc_array_i16 *, const GFC_INTEGER_16 *); +export_proto(cshift1_16); + +void +cshift1_16 (gfc_array_char * ret, + const gfc_array_char * array, + const gfc_array_i16 * h, const GFC_INTEGER_16 * pwhich) +{ + cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array)); +} + +void cshift1_16_char (gfc_array_char * ret, GFC_INTEGER_4, + const gfc_array_char * array, + const gfc_array_i16 * h, const GFC_INTEGER_16 * pwhich, + GFC_INTEGER_4); +export_proto(cshift1_16_char); + +void +cshift1_16_char (gfc_array_char * ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * array, + const gfc_array_i16 * h, const GFC_INTEGER_16 * pwhich, + GFC_INTEGER_4 array_length) +{ + cshift1 (ret, array, h, pwhich, array_length); +} + +#endif diff --git a/libgfortran/generated/cshift1_4.c b/libgfortran/generated/cshift1_4.c index 1fe0e68139f..9f9bea07c1e 100644 --- a/libgfortran/generated/cshift1_4.c +++ b/libgfortran/generated/cshift1_4.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <string.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) + static void cshift1 (gfc_array_char * ret, const gfc_array_char * array, const gfc_array_i4 * h, const GFC_INTEGER_4 * pwhich, index_type size) @@ -219,3 +221,5 @@ cshift1_4_char (gfc_array_char * ret, { cshift1 (ret, array, h, pwhich, array_length); } + +#endif diff --git a/libgfortran/generated/cshift1_8.c b/libgfortran/generated/cshift1_8.c index 8b0cb03f1a8..3a7c509b00c 100644 --- a/libgfortran/generated/cshift1_8.c +++ b/libgfortran/generated/cshift1_8.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <string.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) + static void cshift1 (gfc_array_char * ret, const gfc_array_char * array, const gfc_array_i8 * h, const GFC_INTEGER_8 * pwhich, index_type size) @@ -219,3 +221,5 @@ cshift1_8_char (gfc_array_char * ret, { cshift1 (ret, array, h, pwhich, array_length); } + +#endif diff --git a/libgfortran/generated/dotprod_c10.c b/libgfortran/generated/dotprod_c10.c new file mode 100644 index 00000000000..3fa5955e200 --- /dev/null +++ b/libgfortran/generated/dotprod_c10.c @@ -0,0 +1,82 @@ +/* Implementation of the DOT_PRODUCT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + and Feng Wang <fengwang@nudt.edu.cn> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_10) + +typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) char_array; + +extern GFC_COMPLEX_10 dot_product_c10 (gfc_array_c10 * a, gfc_array_c10 * b); +export_proto(dot_product_c10); + +/* Both parameters will already have been converted to the result type. */ +GFC_COMPLEX_10 +dot_product_c10 (gfc_array_c10 * a, gfc_array_c10 * b) +{ + GFC_COMPLEX_10 *pa; + GFC_COMPLEX_10 *pb; + GFC_COMPLEX_10 res; + GFC_COMPLEX_10 conjga; + index_type count; + index_type astride; + index_type bstride; + + assert (GFC_DESCRIPTOR_RANK (a) == 1 + && GFC_DESCRIPTOR_RANK (b) == 1); + + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + astride = a->dim[0].stride; + bstride = b->dim[0].stride; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + res = 0; + pa = a->data; + pb = b->data; + + while (count--) + { + COMPLEX_ASSIGN(conjga, REALPART (*pa), -IMAGPART (*pa)); + res += conjga * *pb; + pa += astride; + pb += bstride; + } + + return res; +} + +#endif diff --git a/libgfortran/generated/dotprod_c16.c b/libgfortran/generated/dotprod_c16.c new file mode 100644 index 00000000000..a526b533d44 --- /dev/null +++ b/libgfortran/generated/dotprod_c16.c @@ -0,0 +1,82 @@ +/* Implementation of the DOT_PRODUCT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + and Feng Wang <fengwang@nudt.edu.cn> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_16) + +typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) char_array; + +extern GFC_COMPLEX_16 dot_product_c16 (gfc_array_c16 * a, gfc_array_c16 * b); +export_proto(dot_product_c16); + +/* Both parameters will already have been converted to the result type. */ +GFC_COMPLEX_16 +dot_product_c16 (gfc_array_c16 * a, gfc_array_c16 * b) +{ + GFC_COMPLEX_16 *pa; + GFC_COMPLEX_16 *pb; + GFC_COMPLEX_16 res; + GFC_COMPLEX_16 conjga; + index_type count; + index_type astride; + index_type bstride; + + assert (GFC_DESCRIPTOR_RANK (a) == 1 + && GFC_DESCRIPTOR_RANK (b) == 1); + + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + astride = a->dim[0].stride; + bstride = b->dim[0].stride; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + res = 0; + pa = a->data; + pb = b->data; + + while (count--) + { + COMPLEX_ASSIGN(conjga, REALPART (*pa), -IMAGPART (*pa)); + res += conjga * *pb; + pa += astride; + pb += bstride; + } + + return res; +} + +#endif diff --git a/libgfortran/generated/dotprod_c4.c b/libgfortran/generated/dotprod_c4.c index e047a90c2aa..ea27dd8457e 100644 --- a/libgfortran/generated/dotprod_c4.c +++ b/libgfortran/generated/dotprod_c4.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_4) + typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) char_array; extern GFC_COMPLEX_4 dot_product_c4 (gfc_array_c4 * a, gfc_array_c4 * b); @@ -76,3 +78,5 @@ dot_product_c4 (gfc_array_c4 * a, gfc_array_c4 * b) return res; } + +#endif diff --git a/libgfortran/generated/dotprod_c8.c b/libgfortran/generated/dotprod_c8.c index 747d3a1b245..aec5fb5a3bc 100644 --- a/libgfortran/generated/dotprod_c8.c +++ b/libgfortran/generated/dotprod_c8.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_8) + typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) char_array; extern GFC_COMPLEX_8 dot_product_c8 (gfc_array_c8 * a, gfc_array_c8 * b); @@ -76,3 +78,5 @@ dot_product_c8 (gfc_array_c8 * a, gfc_array_c8 * b) return res; } + +#endif diff --git a/libgfortran/generated/dotprod_i16.c b/libgfortran/generated/dotprod_i16.c new file mode 100644 index 00000000000..1c3e5825d0e --- /dev/null +++ b/libgfortran/generated/dotprod_i16.c @@ -0,0 +1,79 @@ +/* Implementation of the DOT_PRODUCT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_INTEGER_16) + +typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) char_array; + +extern GFC_INTEGER_16 dot_product_i16 (gfc_array_i16 * a, gfc_array_i16 * b); +export_proto(dot_product_i16); + +/* Both parameters will already have been converted to the result type. */ +GFC_INTEGER_16 +dot_product_i16 (gfc_array_i16 * a, gfc_array_i16 * b) +{ + GFC_INTEGER_16 *pa; + GFC_INTEGER_16 *pb; + GFC_INTEGER_16 res; + index_type count; + index_type astride; + index_type bstride; + + assert (GFC_DESCRIPTOR_RANK (a) == 1 + && GFC_DESCRIPTOR_RANK (b) == 1); + + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + astride = a->dim[0].stride; + bstride = b->dim[0].stride; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + res = 0; + pa = a->data; + pb = b->data; + + while (count--) + { + res += *pa * *pb; + pa += astride; + pb += bstride; + } + + return res; +} + +#endif diff --git a/libgfortran/generated/dotprod_i4.c b/libgfortran/generated/dotprod_i4.c index 65245ab4de7..aaf8b8d4efa 100644 --- a/libgfortran/generated/dotprod_i4.c +++ b/libgfortran/generated/dotprod_i4.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) + typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) char_array; extern GFC_INTEGER_4 dot_product_i4 (gfc_array_i4 * a, gfc_array_i4 * b); @@ -73,3 +75,5 @@ dot_product_i4 (gfc_array_i4 * a, gfc_array_i4 * b) return res; } + +#endif diff --git a/libgfortran/generated/dotprod_i8.c b/libgfortran/generated/dotprod_i8.c index 3c857e2c39f..44af1f15954 100644 --- a/libgfortran/generated/dotprod_i8.c +++ b/libgfortran/generated/dotprod_i8.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) + typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) char_array; extern GFC_INTEGER_8 dot_product_i8 (gfc_array_i8 * a, gfc_array_i8 * b); @@ -73,3 +75,5 @@ dot_product_i8 (gfc_array_i8 * a, gfc_array_i8 * b) return res; } + +#endif diff --git a/libgfortran/generated/dotprod_l16.c b/libgfortran/generated/dotprod_l16.c new file mode 100644 index 00000000000..977eb4a3915 --- /dev/null +++ b/libgfortran/generated/dotprod_l16.c @@ -0,0 +1,89 @@ +/* Implementation of the DOT_PRODUCT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_LOGICAL_16) + +extern GFC_LOGICAL_16 dot_product_l16 (gfc_array_l4 *, gfc_array_l4 *); +export_proto(dot_product_l16); + +GFC_LOGICAL_16 +dot_product_l16 (gfc_array_l4 * a, gfc_array_l4 * b) +{ + GFC_LOGICAL_4 *pa; + GFC_LOGICAL_4 *pb; + index_type count; + index_type astride; + index_type bstride; + + assert (GFC_DESCRIPTOR_RANK (a) == 1 + && GFC_DESCRIPTOR_RANK (b) == 1); + + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + astride = a->dim[0].stride; + bstride = b->dim[0].stride; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + + pa = a->data; + if (GFC_DESCRIPTOR_SIZE (a) != 4) + { + assert (GFC_DESCRIPTOR_SIZE (a) == 8); + pa = GFOR_POINTER_L8_TO_L4 (pa); + astride <<= 1; + } + pb = b->data; + if (GFC_DESCRIPTOR_SIZE (b) != 4) + { + assert (GFC_DESCRIPTOR_SIZE (b) == 8); + pb = GFOR_POINTER_L8_TO_L4 (pb); + bstride <<= 1; + } + + while (count--) + { + if (*pa && *pb) + return 1; + + pa += astride; + pb += bstride; + } + + return 0; +} + +#endif diff --git a/libgfortran/generated/dotprod_l4.c b/libgfortran/generated/dotprod_l4.c index a8fdf951072..50db3981285 100644 --- a/libgfortran/generated/dotprod_l4.c +++ b/libgfortran/generated/dotprod_l4.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_4) + extern GFC_LOGICAL_4 dot_product_l4 (gfc_array_l4 *, gfc_array_l4 *); export_proto(dot_product_l4); @@ -83,3 +85,5 @@ dot_product_l4 (gfc_array_l4 * a, gfc_array_l4 * b) return 0; } + +#endif diff --git a/libgfortran/generated/dotprod_l8.c b/libgfortran/generated/dotprod_l8.c index cbb2961199a..f857d08ecd5 100644 --- a/libgfortran/generated/dotprod_l8.c +++ b/libgfortran/generated/dotprod_l8.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_8) + extern GFC_LOGICAL_8 dot_product_l8 (gfc_array_l4 *, gfc_array_l4 *); export_proto(dot_product_l8); @@ -83,3 +85,5 @@ dot_product_l8 (gfc_array_l4 * a, gfc_array_l4 * b) return 0; } + +#endif diff --git a/libgfortran/generated/dotprod_r10.c b/libgfortran/generated/dotprod_r10.c new file mode 100644 index 00000000000..055c28837c4 --- /dev/null +++ b/libgfortran/generated/dotprod_r10.c @@ -0,0 +1,79 @@ +/* Implementation of the DOT_PRODUCT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_REAL_10) + +typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) char_array; + +extern GFC_REAL_10 dot_product_r10 (gfc_array_r10 * a, gfc_array_r10 * b); +export_proto(dot_product_r10); + +/* Both parameters will already have been converted to the result type. */ +GFC_REAL_10 +dot_product_r10 (gfc_array_r10 * a, gfc_array_r10 * b) +{ + GFC_REAL_10 *pa; + GFC_REAL_10 *pb; + GFC_REAL_10 res; + index_type count; + index_type astride; + index_type bstride; + + assert (GFC_DESCRIPTOR_RANK (a) == 1 + && GFC_DESCRIPTOR_RANK (b) == 1); + + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + astride = a->dim[0].stride; + bstride = b->dim[0].stride; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + res = 0; + pa = a->data; + pb = b->data; + + while (count--) + { + res += *pa * *pb; + pa += astride; + pb += bstride; + } + + return res; +} + +#endif diff --git a/libgfortran/generated/dotprod_r16.c b/libgfortran/generated/dotprod_r16.c new file mode 100644 index 00000000000..e14eaac4208 --- /dev/null +++ b/libgfortran/generated/dotprod_r16.c @@ -0,0 +1,79 @@ +/* Implementation of the DOT_PRODUCT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_REAL_16) + +typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) char_array; + +extern GFC_REAL_16 dot_product_r16 (gfc_array_r16 * a, gfc_array_r16 * b); +export_proto(dot_product_r16); + +/* Both parameters will already have been converted to the result type. */ +GFC_REAL_16 +dot_product_r16 (gfc_array_r16 * a, gfc_array_r16 * b) +{ + GFC_REAL_16 *pa; + GFC_REAL_16 *pb; + GFC_REAL_16 res; + index_type count; + index_type astride; + index_type bstride; + + assert (GFC_DESCRIPTOR_RANK (a) == 1 + && GFC_DESCRIPTOR_RANK (b) == 1); + + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + astride = a->dim[0].stride; + bstride = b->dim[0].stride; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + res = 0; + pa = a->data; + pb = b->data; + + while (count--) + { + res += *pa * *pb; + pa += astride; + pb += bstride; + } + + return res; +} + +#endif diff --git a/libgfortran/generated/dotprod_r4.c b/libgfortran/generated/dotprod_r4.c index 28f8fcdb6b5..bae99ab3f36 100644 --- a/libgfortran/generated/dotprod_r4.c +++ b/libgfortran/generated/dotprod_r4.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) + typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) char_array; extern GFC_REAL_4 dot_product_r4 (gfc_array_r4 * a, gfc_array_r4 * b); @@ -73,3 +75,5 @@ dot_product_r4 (gfc_array_r4 * a, gfc_array_r4 * b) return res; } + +#endif diff --git a/libgfortran/generated/dotprod_r8.c b/libgfortran/generated/dotprod_r8.c index b0e704e306d..84a6aaa0110 100644 --- a/libgfortran/generated/dotprod_r8.c +++ b/libgfortran/generated/dotprod_r8.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) + typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) char_array; extern GFC_REAL_8 dot_product_r8 (gfc_array_r8 * a, gfc_array_r8 * b); @@ -73,3 +75,5 @@ dot_product_r8 (gfc_array_r8 * a, gfc_array_r8 * b) return res; } + +#endif diff --git a/libgfortran/generated/eoshift1_16.c b/libgfortran/generated/eoshift1_16.c new file mode 100644 index 00000000000..c548fef3ae4 --- /dev/null +++ b/libgfortran/generated/eoshift1_16.c @@ -0,0 +1,251 @@ +/* Implementation of the EOSHIFT intrinsic + Copyright 2002, 2005 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_INTEGER_16) + +static void +eoshift1 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i16 *h, + const char *pbound, const GFC_INTEGER_16 *pwhich, index_type size, + char filler) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char *rptr; + char *dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const char *sptr; + const char *src; + /* h.* indicates the shift array. */ + index_type hstride[GFC_MAX_DIMENSIONS]; + index_type hstride0; + const GFC_INTEGER_16 *hptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + int which; + GFC_INTEGER_16 sh; + GFC_INTEGER_16 delta; + + /* The compiler cannot figure out that these are set, initialize + them to avoid warnings. */ + len = 0; + soffset = 0; + roffset = 0; + + if (pwhich) + which = *pwhich - 1; + else + which = 0; + + extent[0] = 1; + count[0] = 0; + + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + + n = 0; + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = ret->dim[dim].stride * size; + if (roffset == 0) + roffset = size; + soffset = array->dim[dim].stride * size; + if (soffset == 0) + soffset = size; + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + } + else + { + count[n] = 0; + extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + rstride[n] = ret->dim[dim].stride * size; + sstride[n] = array->dim[dim].stride * size; + + hstride[n] = h->dim[n].stride; + n++; + } + } + if (sstride[0] == 0) + sstride[0] = size; + if (rstride[0] == 0) + rstride[0] = size; + if (hstride[0] == 0) + hstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + hstride0 = hstride[0]; + rptr = ret->data; + sptr = array->data; + hptr = h->data; + + while (rptr) + { + /* Do the shift for this dimension. */ + sh = *hptr; + if (( sh >= 0 ? sh : -sh ) > len) + { + delta = len; + sh = len; + } + else + delta = (sh >= 0) ? sh: -sh; + + if (sh > 0) + { + src = &sptr[delta * soffset]; + dest = rptr; + } + else + { + src = sptr; + dest = &rptr[delta * roffset]; + } + for (n = 0; n < len - delta; n++) + { + memcpy (dest, src, size); + dest += roffset; + src += soffset; + } + if (sh < 0) + dest = rptr; + n = delta; + + if (pbound) + while (n--) + { + memcpy (dest, pbound, size); + dest += roffset; + } + else + while (n--) + { + memset (dest, filler, size); + dest += roffset; + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + hptr += hstride0; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[n] * extent[n]; + hptr -= hstride[n] * extent[n]; + n++; + if (n >= dim - 1) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + sptr += sstride[n]; + hptr += hstride[n]; + } + } + } +} + +void eoshift1_16 (gfc_array_char *, const gfc_array_char *, + const gfc_array_i16 *, const char *, const GFC_INTEGER_16 *); +export_proto(eoshift1_16); + +void +eoshift1_16 (gfc_array_char *ret, const gfc_array_char *array, + const gfc_array_i16 *h, const char *pbound, + const GFC_INTEGER_16 *pwhich) +{ + eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); +} + +void eoshift1_16_char (gfc_array_char *, GFC_INTEGER_4, + const gfc_array_char *, const gfc_array_i16 *, + const char *, const GFC_INTEGER_16 *, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_16_char); + +void +eoshift1_16_char (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *array, const gfc_array_i16 *h, + const char *pbound, const GFC_INTEGER_16 *pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length + __attribute__((unused))) +{ + eoshift1 (ret, array, h, pbound, pwhich, array_length, ' '); +} + +#endif diff --git a/libgfortran/generated/eoshift1_4.c b/libgfortran/generated/eoshift1_4.c index e08042ac37d..8045679ce92 100644 --- a/libgfortran/generated/eoshift1_4.c +++ b/libgfortran/generated/eoshift1_4.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <string.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) + static void eoshift1 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i4 *h, const char *pbound, const GFC_INTEGER_4 *pwhich, index_type size, @@ -245,3 +247,5 @@ eoshift1_4_char (gfc_array_char *ret, { eoshift1 (ret, array, h, pbound, pwhich, array_length, ' '); } + +#endif diff --git a/libgfortran/generated/eoshift1_8.c b/libgfortran/generated/eoshift1_8.c index f375a825113..bcc53ab7054 100644 --- a/libgfortran/generated/eoshift1_8.c +++ b/libgfortran/generated/eoshift1_8.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <string.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) + static void eoshift1 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i8 *h, const char *pbound, const GFC_INTEGER_8 *pwhich, index_type size, @@ -245,3 +247,5 @@ eoshift1_8_char (gfc_array_char *ret, { eoshift1 (ret, array, h, pbound, pwhich, array_length, ' '); } + +#endif diff --git a/libgfortran/generated/eoshift3_16.c b/libgfortran/generated/eoshift3_16.c new file mode 100644 index 00000000000..d03c1c7f1c9 --- /dev/null +++ b/libgfortran/generated/eoshift3_16.c @@ -0,0 +1,273 @@ +/* Implementation of the EOSHIFT intrinsic + Copyright 2002, 2005 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_INTEGER_16) + +static void +eoshift3 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i16 *h, + const gfc_array_char *bound, const GFC_INTEGER_16 *pwhich, + index_type size, char filler) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char *rptr; + char *dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const char *sptr; + const char *src; + /* h.* indicates the shift array. */ + index_type hstride[GFC_MAX_DIMENSIONS]; + index_type hstride0; + const GFC_INTEGER_16 *hptr; + /* b.* indicates the bound array. */ + index_type bstride[GFC_MAX_DIMENSIONS]; + index_type bstride0; + const char *bptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + int which; + GFC_INTEGER_16 sh; + GFC_INTEGER_16 delta; + + /* The compiler cannot figure out that these are set, initialize + them to avoid warnings. */ + len = 0; + soffset = 0; + roffset = 0; + + if (pwhich) + which = *pwhich - 1; + else + which = 0; + + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + + + extent[0] = 1; + count[0] = 0; + n = 0; + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = ret->dim[dim].stride * size; + if (roffset == 0) + roffset = size; + soffset = array->dim[dim].stride * size; + if (soffset == 0) + soffset = size; + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + } + else + { + count[n] = 0; + extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + rstride[n] = ret->dim[dim].stride * size; + sstride[n] = array->dim[dim].stride * size; + + hstride[n] = h->dim[n].stride; + if (bound) + bstride[n] = bound->dim[n].stride * size; + else + bstride[n] = 0; + n++; + } + } + if (sstride[0] == 0) + sstride[0] = size; + if (rstride[0] == 0) + rstride[0] = size; + if (hstride[0] == 0) + hstride[0] = 1; + if (bound && bstride[0] == 0) + bstride[0] = size; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + hstride0 = hstride[0]; + bstride0 = bstride[0]; + rptr = ret->data; + sptr = array->data; + hptr = h->data; + if (bound) + bptr = bound->data; + else + bptr = NULL; + + while (rptr) + { + /* Do the shift for this dimension. */ + sh = *hptr; + if (( sh >= 0 ? sh : -sh ) > len) + { + delta = len; + sh = len; + } + else + delta = (sh >= 0) ? sh: -sh; + + if (sh > 0) + { + src = &sptr[delta * soffset]; + dest = rptr; + } + else + { + src = sptr; + dest = &rptr[delta * roffset]; + } + for (n = 0; n < len - delta; n++) + { + memcpy (dest, src, size); + dest += roffset; + src += soffset; + } + if (sh < 0) + dest = rptr; + n = delta; + + if (bptr) + while (n--) + { + memcpy (dest, bptr, size); + dest += roffset; + } + else + while (n--) + { + memset (dest, filler, size); + dest += roffset; + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + hptr += hstride0; + bptr += bstride0; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[n] * extent[n]; + hptr -= hstride[n] * extent[n]; + bptr -= bstride[n] * extent[n]; + n++; + if (n >= dim - 1) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + sptr += sstride[n]; + hptr += hstride[n]; + bptr += bstride[n]; + } + } + } +} + +extern void eoshift3_16 (gfc_array_char *, const gfc_array_char *, + const gfc_array_i16 *, const gfc_array_char *, + const GFC_INTEGER_16 *); +export_proto(eoshift3_16); + +void +eoshift3_16 (gfc_array_char *ret, const gfc_array_char *array, + const gfc_array_i16 *h, const gfc_array_char *bound, + const GFC_INTEGER_16 *pwhich) +{ + eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); +} + +extern void eoshift3_16_char (gfc_array_char *, GFC_INTEGER_4, + const gfc_array_char *, + const gfc_array_i16 *, + const gfc_array_char *, + const GFC_INTEGER_16 *, GFC_INTEGER_4, + GFC_INTEGER_4); +export_proto(eoshift3_16_char); + +void +eoshift3_16_char (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *array, const gfc_array_i16 *h, + const gfc_array_char *bound, + const GFC_INTEGER_16 *pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length + __attribute__((unused))) +{ + eoshift3 (ret, array, h, bound, pwhich, array_length, ' '); +} + +#endif diff --git a/libgfortran/generated/eoshift3_4.c b/libgfortran/generated/eoshift3_4.c index 09e0207cef9..2b84ece377c 100644 --- a/libgfortran/generated/eoshift3_4.c +++ b/libgfortran/generated/eoshift3_4.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <string.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) + static void eoshift3 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i4 *h, const gfc_array_char *bound, const GFC_INTEGER_4 *pwhich, @@ -267,3 +269,5 @@ eoshift3_4_char (gfc_array_char *ret, { eoshift3 (ret, array, h, bound, pwhich, array_length, ' '); } + +#endif diff --git a/libgfortran/generated/eoshift3_8.c b/libgfortran/generated/eoshift3_8.c index c652d98d018..ba2ef1faa33 100644 --- a/libgfortran/generated/eoshift3_8.c +++ b/libgfortran/generated/eoshift3_8.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <string.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) + static void eoshift3 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i8 *h, const gfc_array_char *bound, const GFC_INTEGER_8 *pwhich, @@ -267,3 +269,5 @@ eoshift3_8_char (gfc_array_char *ret, { eoshift3 (ret, array, h, bound, pwhich, array_length, ' '); } + +#endif diff --git a/libgfortran/generated/exponent_r10.c b/libgfortran/generated/exponent_r10.c new file mode 100644 index 00000000000..da2d33b1262 --- /dev/null +++ b/libgfortran/generated/exponent_r10.c @@ -0,0 +1,49 @@ +/* Implementation of the EXPONENT intrinsic + Copyright 2003 Free Software Foundation, Inc. + Contributed by Richard Henderson <rth@redhat.com>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <math.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_FREXPL) + +extern GFC_INTEGER_4 exponent_r10 (GFC_REAL_10 s); +export_proto(exponent_r10); + +GFC_INTEGER_4 +exponent_r10 (GFC_REAL_10 s) +{ + int ret; + frexpl (s, &ret); + return ret; +} + +#endif diff --git a/libgfortran/generated/exponent_r16.c b/libgfortran/generated/exponent_r16.c new file mode 100644 index 00000000000..de1769e3144 --- /dev/null +++ b/libgfortran/generated/exponent_r16.c @@ -0,0 +1,49 @@ +/* Implementation of the EXPONENT intrinsic + Copyright 2003 Free Software Foundation, Inc. + Contributed by Richard Henderson <rth@redhat.com>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <math.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_FREXPL) + +extern GFC_INTEGER_4 exponent_r16 (GFC_REAL_16 s); +export_proto(exponent_r16); + +GFC_INTEGER_4 +exponent_r16 (GFC_REAL_16 s) +{ + int ret; + frexpl (s, &ret); + return ret; +} + +#endif diff --git a/libgfortran/generated/exponent_r4.c b/libgfortran/generated/exponent_r4.c index 3d0ffb370d9..9a9c7ebfcfe 100644 --- a/libgfortran/generated/exponent_r4.c +++ b/libgfortran/generated/exponent_r4.c @@ -27,10 +27,14 @@ You should have received a copy of the GNU General Public License along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include "config.h" #include <math.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_FREXPF) + extern GFC_INTEGER_4 exponent_r4 (GFC_REAL_4 s); export_proto(exponent_r4); @@ -41,3 +45,5 @@ exponent_r4 (GFC_REAL_4 s) frexpf (s, &ret); return ret; } + +#endif diff --git a/libgfortran/generated/exponent_r8.c b/libgfortran/generated/exponent_r8.c index 9fc8bff27b1..d41bf9a44c0 100644 --- a/libgfortran/generated/exponent_r8.c +++ b/libgfortran/generated/exponent_r8.c @@ -27,10 +27,14 @@ You should have received a copy of the GNU General Public License along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include "config.h" #include <math.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_FREXP) + extern GFC_INTEGER_4 exponent_r8 (GFC_REAL_8 s); export_proto(exponent_r8); @@ -41,3 +45,5 @@ exponent_r8 (GFC_REAL_8 s) frexp (s, &ret); return ret; } + +#endif diff --git a/libgfortran/generated/fraction_r10.c b/libgfortran/generated/fraction_r10.c new file mode 100644 index 00000000000..aac9811af5e --- /dev/null +++ b/libgfortran/generated/fraction_r10.c @@ -0,0 +1,48 @@ +/* Implementation of the FRACTION intrinsic + Copyright 2003 Free Software Foundation, Inc. + Contributed by Richard Henderson <rth@redhat.com>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <math.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_FREXPL) + +extern GFC_REAL_10 fraction_r10 (GFC_REAL_10 s); +export_proto(fraction_r10); + +GFC_REAL_10 +fraction_r10 (GFC_REAL_10 s) +{ + int dummy_exp; + return frexpl (s, &dummy_exp); +} + +#endif diff --git a/libgfortran/generated/fraction_r16.c b/libgfortran/generated/fraction_r16.c new file mode 100644 index 00000000000..399682a8344 --- /dev/null +++ b/libgfortran/generated/fraction_r16.c @@ -0,0 +1,48 @@ +/* Implementation of the FRACTION intrinsic + Copyright 2003 Free Software Foundation, Inc. + Contributed by Richard Henderson <rth@redhat.com>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <math.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_FREXPL) + +extern GFC_REAL_16 fraction_r16 (GFC_REAL_16 s); +export_proto(fraction_r16); + +GFC_REAL_16 +fraction_r16 (GFC_REAL_16 s) +{ + int dummy_exp; + return frexpl (s, &dummy_exp); +} + +#endif diff --git a/libgfortran/generated/fraction_r4.c b/libgfortran/generated/fraction_r4.c index d7ca25f0d35..252335041d1 100644 --- a/libgfortran/generated/fraction_r4.c +++ b/libgfortran/generated/fraction_r4.c @@ -27,10 +27,14 @@ You should have received a copy of the GNU General Public License along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include "config.h" #include <math.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_FREXPF) + extern GFC_REAL_4 fraction_r4 (GFC_REAL_4 s); export_proto(fraction_r4); @@ -40,3 +44,5 @@ fraction_r4 (GFC_REAL_4 s) int dummy_exp; return frexpf (s, &dummy_exp); } + +#endif diff --git a/libgfortran/generated/fraction_r8.c b/libgfortran/generated/fraction_r8.c index d9b6c44ac70..492e4540a81 100644 --- a/libgfortran/generated/fraction_r8.c +++ b/libgfortran/generated/fraction_r8.c @@ -27,10 +27,14 @@ You should have received a copy of the GNU General Public License along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include "config.h" #include <math.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_FREXP) + extern GFC_REAL_8 fraction_r8 (GFC_REAL_8 s); export_proto(fraction_r8); @@ -40,3 +44,5 @@ fraction_r8 (GFC_REAL_8 s) int dummy_exp; return frexp (s, &dummy_exp); } + +#endif diff --git a/libgfortran/generated/in_pack_c10.c b/libgfortran/generated/in_pack_c10.c new file mode 100644 index 00000000000..5a91d9765bc --- /dev/null +++ b/libgfortran/generated/in_pack_c10.c @@ -0,0 +1,126 @@ +/* Helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_10) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_COMPLEX_10 * +internal_pack_c10 (gfc_array_c10 * source) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + index_type ssize; + const GFC_COMPLEX_10 *src; + GFC_COMPLEX_10 *dest; + GFC_COMPLEX_10 *destptr; + int n; + int packed; + + if (source->dim[0].stride == 0) + { + source->dim[0].stride = 1; + return source->data; + } + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = source->dim[n].stride; + extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; + if (extent[n] <= 0) + { + /* Do nothing. */ + packed = 1; + break; + } + + if (ssize != stride[n]) + packed = 0; + + ssize *= extent[n]; + } + + if (packed) + return source->data; + + /* Allocate storage for the destination. */ + destptr = (GFC_COMPLEX_10 *)internal_malloc_size (ssize * sizeof (GFC_COMPLEX_10)); + dest = destptr; + src = source->data; + stride0 = stride[0]; + + + while (src) + { + /* Copy the data. */ + *(dest++) = *src; + /* Advance to the next element. */ + src += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + src -= stride[n] * extent[n]; + n++; + if (n == dim) + { + src = NULL; + break; + } + else + { + count[n]++; + src += stride[n]; + } + } + } + return destptr; +} + +#endif diff --git a/libgfortran/generated/in_pack_c16.c b/libgfortran/generated/in_pack_c16.c new file mode 100644 index 00000000000..d52249b648f --- /dev/null +++ b/libgfortran/generated/in_pack_c16.c @@ -0,0 +1,126 @@ +/* Helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_16) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_COMPLEX_16 * +internal_pack_c16 (gfc_array_c16 * source) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + index_type ssize; + const GFC_COMPLEX_16 *src; + GFC_COMPLEX_16 *dest; + GFC_COMPLEX_16 *destptr; + int n; + int packed; + + if (source->dim[0].stride == 0) + { + source->dim[0].stride = 1; + return source->data; + } + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = source->dim[n].stride; + extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; + if (extent[n] <= 0) + { + /* Do nothing. */ + packed = 1; + break; + } + + if (ssize != stride[n]) + packed = 0; + + ssize *= extent[n]; + } + + if (packed) + return source->data; + + /* Allocate storage for the destination. */ + destptr = (GFC_COMPLEX_16 *)internal_malloc_size (ssize * sizeof (GFC_COMPLEX_16)); + dest = destptr; + src = source->data; + stride0 = stride[0]; + + + while (src) + { + /* Copy the data. */ + *(dest++) = *src; + /* Advance to the next element. */ + src += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + src -= stride[n] * extent[n]; + n++; + if (n == dim) + { + src = NULL; + break; + } + else + { + count[n]++; + src += stride[n]; + } + } + } + return destptr; +} + +#endif diff --git a/libgfortran/generated/in_pack_c4.c b/libgfortran/generated/in_pack_c4.c index c1446ad02b3..a4fd70909d5 100644 --- a/libgfortran/generated/in_pack_c4.c +++ b/libgfortran/generated/in_pack_c4.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_4) + /* Allocates a block of memory with internal_malloc if the array needs repacking. */ @@ -121,3 +123,4 @@ internal_pack_c4 (gfc_array_c4 * source) return destptr; } +#endif diff --git a/libgfortran/generated/in_pack_c8.c b/libgfortran/generated/in_pack_c8.c index 666585960c3..a3c6214026e 100644 --- a/libgfortran/generated/in_pack_c8.c +++ b/libgfortran/generated/in_pack_c8.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_8) + /* Allocates a block of memory with internal_malloc if the array needs repacking. */ @@ -121,3 +123,4 @@ internal_pack_c8 (gfc_array_c8 * source) return destptr; } +#endif diff --git a/libgfortran/generated/in_pack_i16.c b/libgfortran/generated/in_pack_i16.c new file mode 100644 index 00000000000..b8c6c29d6f7 --- /dev/null +++ b/libgfortran/generated/in_pack_i16.c @@ -0,0 +1,126 @@ +/* Helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_INTEGER_16) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_INTEGER_16 * +internal_pack_16 (gfc_array_i16 * source) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + index_type ssize; + const GFC_INTEGER_16 *src; + GFC_INTEGER_16 *dest; + GFC_INTEGER_16 *destptr; + int n; + int packed; + + if (source->dim[0].stride == 0) + { + source->dim[0].stride = 1; + return source->data; + } + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = source->dim[n].stride; + extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; + if (extent[n] <= 0) + { + /* Do nothing. */ + packed = 1; + break; + } + + if (ssize != stride[n]) + packed = 0; + + ssize *= extent[n]; + } + + if (packed) + return source->data; + + /* Allocate storage for the destination. */ + destptr = (GFC_INTEGER_16 *)internal_malloc_size (ssize * sizeof (GFC_INTEGER_16)); + dest = destptr; + src = source->data; + stride0 = stride[0]; + + + while (src) + { + /* Copy the data. */ + *(dest++) = *src; + /* Advance to the next element. */ + src += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + src -= stride[n] * extent[n]; + n++; + if (n == dim) + { + src = NULL; + break; + } + else + { + count[n]++; + src += stride[n]; + } + } + } + return destptr; +} + +#endif diff --git a/libgfortran/generated/in_pack_i4.c b/libgfortran/generated/in_pack_i4.c index 1034bde0e89..4452c644d71 100644 --- a/libgfortran/generated/in_pack_i4.c +++ b/libgfortran/generated/in_pack_i4.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) + /* Allocates a block of memory with internal_malloc if the array needs repacking. */ @@ -121,3 +123,4 @@ internal_pack_4 (gfc_array_i4 * source) return destptr; } +#endif diff --git a/libgfortran/generated/in_pack_i8.c b/libgfortran/generated/in_pack_i8.c index aa7e98c38c5..35e48422897 100644 --- a/libgfortran/generated/in_pack_i8.c +++ b/libgfortran/generated/in_pack_i8.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) + /* Allocates a block of memory with internal_malloc if the array needs repacking. */ @@ -121,3 +123,4 @@ internal_pack_8 (gfc_array_i8 * source) return destptr; } +#endif diff --git a/libgfortran/generated/in_unpack_c10.c b/libgfortran/generated/in_unpack_c10.c new file mode 100644 index 00000000000..d7983f96ce6 --- /dev/null +++ b/libgfortran/generated/in_unpack_c10.c @@ -0,0 +1,114 @@ +/* Helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_10) + +void +internal_unpack_c10 (gfc_array_c10 * d, const GFC_COMPLEX_10 * src) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + index_type dsize; + GFC_COMPLEX_10 *dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + if (d->dim[0].stride == 0) + d->dim[0].stride = 1; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = d->dim[n].stride; + extent[n] = d->dim[n].ubound + 1 - d->dim[n].lbound; + if (extent[n] <= 0) + abort (); + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_COMPLEX_10)); + return; + } + + stride0 = stride[0]; + + while (dest) + { + /* Copy the data. */ + *dest = *(src++); + /* Advance to the next element. */ + dest += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + dest -= stride[n] * extent[n]; + n++; + if (n == dim) + { + dest = NULL; + break; + } + else + { + count[n]++; + dest += stride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/in_unpack_c16.c b/libgfortran/generated/in_unpack_c16.c new file mode 100644 index 00000000000..9f1baf27911 --- /dev/null +++ b/libgfortran/generated/in_unpack_c16.c @@ -0,0 +1,114 @@ +/* Helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_16) + +void +internal_unpack_c16 (gfc_array_c16 * d, const GFC_COMPLEX_16 * src) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + index_type dsize; + GFC_COMPLEX_16 *dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + if (d->dim[0].stride == 0) + d->dim[0].stride = 1; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = d->dim[n].stride; + extent[n] = d->dim[n].ubound + 1 - d->dim[n].lbound; + if (extent[n] <= 0) + abort (); + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_COMPLEX_16)); + return; + } + + stride0 = stride[0]; + + while (dest) + { + /* Copy the data. */ + *dest = *(src++); + /* Advance to the next element. */ + dest += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + dest -= stride[n] * extent[n]; + n++; + if (n == dim) + { + dest = NULL; + break; + } + else + { + count[n]++; + dest += stride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/in_unpack_c4.c b/libgfortran/generated/in_unpack_c4.c index 7388ec9d1da..965b53a9c70 100644 --- a/libgfortran/generated/in_unpack_c4.c +++ b/libgfortran/generated/in_unpack_c4.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <string.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_4) + void internal_unpack_c4 (gfc_array_c4 * d, const GFC_COMPLEX_4 * src) { @@ -109,3 +111,4 @@ internal_unpack_c4 (gfc_array_c4 * d, const GFC_COMPLEX_4 * src) } } +#endif diff --git a/libgfortran/generated/in_unpack_c8.c b/libgfortran/generated/in_unpack_c8.c index dc0e20dc7f4..b5d747a7a99 100644 --- a/libgfortran/generated/in_unpack_c8.c +++ b/libgfortran/generated/in_unpack_c8.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <string.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_8) + void internal_unpack_c8 (gfc_array_c8 * d, const GFC_COMPLEX_8 * src) { @@ -109,3 +111,4 @@ internal_unpack_c8 (gfc_array_c8 * d, const GFC_COMPLEX_8 * src) } } +#endif diff --git a/libgfortran/generated/in_unpack_i16.c b/libgfortran/generated/in_unpack_i16.c new file mode 100644 index 00000000000..680b5dd2b59 --- /dev/null +++ b/libgfortran/generated/in_unpack_i16.c @@ -0,0 +1,114 @@ +/* Helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_INTEGER_16) + +void +internal_unpack_16 (gfc_array_i16 * d, const GFC_INTEGER_16 * src) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + index_type dsize; + GFC_INTEGER_16 *dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + if (d->dim[0].stride == 0) + d->dim[0].stride = 1; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = d->dim[n].stride; + extent[n] = d->dim[n].ubound + 1 - d->dim[n].lbound; + if (extent[n] <= 0) + abort (); + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_INTEGER_16)); + return; + } + + stride0 = stride[0]; + + while (dest) + { + /* Copy the data. */ + *dest = *(src++); + /* Advance to the next element. */ + dest += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + dest -= stride[n] * extent[n]; + n++; + if (n == dim) + { + dest = NULL; + break; + } + else + { + count[n]++; + dest += stride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/in_unpack_i4.c b/libgfortran/generated/in_unpack_i4.c index 8664b8c9925..6cf7bd2f273 100644 --- a/libgfortran/generated/in_unpack_i4.c +++ b/libgfortran/generated/in_unpack_i4.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <string.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) + void internal_unpack_4 (gfc_array_i4 * d, const GFC_INTEGER_4 * src) { @@ -109,3 +111,4 @@ internal_unpack_4 (gfc_array_i4 * d, const GFC_INTEGER_4 * src) } } +#endif diff --git a/libgfortran/generated/in_unpack_i8.c b/libgfortran/generated/in_unpack_i8.c index 8117c2ce8cb..1d4f0e459ab 100644 --- a/libgfortran/generated/in_unpack_i8.c +++ b/libgfortran/generated/in_unpack_i8.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <string.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) + void internal_unpack_8 (gfc_array_i8 * d, const GFC_INTEGER_8 * src) { @@ -109,3 +111,4 @@ internal_unpack_8 (gfc_array_i8 * d, const GFC_INTEGER_8 * src) } } +#endif diff --git a/libgfortran/generated/matmul_c10.c b/libgfortran/generated/matmul_c10.c new file mode 100644 index 00000000000..801649aa29d --- /dev/null +++ b/libgfortran/generated/matmul_c10.c @@ -0,0 +1,221 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_10) + +/* This is a C version of the following fortran pseudo-code. The key + point is the loop order -- we access all arrays column-first, which + improves the performance enough to boost galgel spec score by 50%. + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + C = 0 + DO J=1,N + DO K=1,COUNT + DO I=1,M + C(I,J) = C(I,J)+A(I,K)*B(K,J) +*/ + +extern void matmul_c10 (gfc_array_c10 * retarray, gfc_array_c10 * a, gfc_array_c10 * b); +export_proto(matmul_c10); + +void +matmul_c10 (gfc_array_c10 * retarray, gfc_array_c10 * a, gfc_array_c10 * b) +{ + GFC_COMPLEX_10 *abase; + GFC_COMPLEX_10 *bbase; + GFC_COMPLEX_10 *dest; + + index_type rxstride, rystride, axstride, aystride, bxstride, bystride; + index_type x, y, n, count, xcount, ycount; + + assert (GFC_DESCRIPTOR_RANK (a) == 2 + || GFC_DESCRIPTOR_RANK (b) == 2); + +/* C[xcount,ycount] = A[xcount, count] * B[count,ycount] + + Either A or B (but not both) can be rank 1: + + o One-dimensional argument A is implicitly treated as a row matrix + dimensioned [1,count], so xcount=1. + + o One-dimensional argument B is implicitly treated as a column matrix + dimensioned [count, 1], so ycount=1. + */ + + if (retarray->data == NULL) + { + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[0].stride = 1; + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + } + else + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + + retarray->dim[1].lbound = 0; + retarray->dim[1].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[1].stride = retarray->dim[0].ubound+1; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_10) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + + if (GFC_DESCRIPTOR_RANK (retarray) == 1) + { + /* One-dimensional result may be addressed in the code below + either as a row or a column matrix. We want both cases to + work. */ + rxstride = rystride = retarray->dim[0].stride; + } + else + { + rxstride = retarray->dim[0].stride; + rystride = retarray->dim[1].stride; + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = a->dim[0].stride; + aystride = 1; + + xcount = 1; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + } + else + { + axstride = a->dim[0].stride; + aystride = a->dim[1].stride; + + count = a->dim[1].ubound + 1 - a->dim[1].lbound; + xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; + } + + assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = b->dim[0].stride; + + /* bystride should never be used for 1-dimensional b. + in case it is we want it to cause a segfault, rather than + an incorrect result. */ + bystride = 0xDEADBEEF; + ycount = 1; + } + else + { + bxstride = b->dim[0].stride; + bystride = b->dim[1].stride; + ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + GFC_COMPLEX_10 *bbase_y; + GFC_COMPLEX_10 *dest_y; + GFC_COMPLEX_10 *abase_n; + GFC_COMPLEX_10 bbase_yn; + + if (rystride == ycount) + memset (dest, 0, (sizeof (GFC_COMPLEX_10) * size0((array_t *) retarray))); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_COMPLEX_10)0; + } + + for (y = 0; y < ycount; y++) + { + bbase_y = bbase + y*bystride; + dest_y = dest + y*rystride; + for (n = 0; n < count; n++) + { + abase_n = abase + n*aystride; + bbase_yn = bbase_y[n]; + for (x = 0; x < xcount; x++) + { + dest_y[x] += abase_n[x] * bbase_yn; + } + } + } + } + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_COMPLEX_10)0; + + for (y = 0; y < ycount; y++) + for (n = 0; n < count; n++) + for (x = 0; x < xcount; x++) + /* dest[x,y] += a[x,n] * b[n,y] */ + dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; + } +} + +#endif diff --git a/libgfortran/generated/matmul_c16.c b/libgfortran/generated/matmul_c16.c new file mode 100644 index 00000000000..fb4870cba39 --- /dev/null +++ b/libgfortran/generated/matmul_c16.c @@ -0,0 +1,221 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_16) + +/* This is a C version of the following fortran pseudo-code. The key + point is the loop order -- we access all arrays column-first, which + improves the performance enough to boost galgel spec score by 50%. + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + C = 0 + DO J=1,N + DO K=1,COUNT + DO I=1,M + C(I,J) = C(I,J)+A(I,K)*B(K,J) +*/ + +extern void matmul_c16 (gfc_array_c16 * retarray, gfc_array_c16 * a, gfc_array_c16 * b); +export_proto(matmul_c16); + +void +matmul_c16 (gfc_array_c16 * retarray, gfc_array_c16 * a, gfc_array_c16 * b) +{ + GFC_COMPLEX_16 *abase; + GFC_COMPLEX_16 *bbase; + GFC_COMPLEX_16 *dest; + + index_type rxstride, rystride, axstride, aystride, bxstride, bystride; + index_type x, y, n, count, xcount, ycount; + + assert (GFC_DESCRIPTOR_RANK (a) == 2 + || GFC_DESCRIPTOR_RANK (b) == 2); + +/* C[xcount,ycount] = A[xcount, count] * B[count,ycount] + + Either A or B (but not both) can be rank 1: + + o One-dimensional argument A is implicitly treated as a row matrix + dimensioned [1,count], so xcount=1. + + o One-dimensional argument B is implicitly treated as a column matrix + dimensioned [count, 1], so ycount=1. + */ + + if (retarray->data == NULL) + { + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[0].stride = 1; + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + } + else + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + + retarray->dim[1].lbound = 0; + retarray->dim[1].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[1].stride = retarray->dim[0].ubound+1; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_16) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + + if (GFC_DESCRIPTOR_RANK (retarray) == 1) + { + /* One-dimensional result may be addressed in the code below + either as a row or a column matrix. We want both cases to + work. */ + rxstride = rystride = retarray->dim[0].stride; + } + else + { + rxstride = retarray->dim[0].stride; + rystride = retarray->dim[1].stride; + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = a->dim[0].stride; + aystride = 1; + + xcount = 1; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + } + else + { + axstride = a->dim[0].stride; + aystride = a->dim[1].stride; + + count = a->dim[1].ubound + 1 - a->dim[1].lbound; + xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; + } + + assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = b->dim[0].stride; + + /* bystride should never be used for 1-dimensional b. + in case it is we want it to cause a segfault, rather than + an incorrect result. */ + bystride = 0xDEADBEEF; + ycount = 1; + } + else + { + bxstride = b->dim[0].stride; + bystride = b->dim[1].stride; + ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + GFC_COMPLEX_16 *bbase_y; + GFC_COMPLEX_16 *dest_y; + GFC_COMPLEX_16 *abase_n; + GFC_COMPLEX_16 bbase_yn; + + if (rystride == ycount) + memset (dest, 0, (sizeof (GFC_COMPLEX_16) * size0((array_t *) retarray))); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_COMPLEX_16)0; + } + + for (y = 0; y < ycount; y++) + { + bbase_y = bbase + y*bystride; + dest_y = dest + y*rystride; + for (n = 0; n < count; n++) + { + abase_n = abase + n*aystride; + bbase_yn = bbase_y[n]; + for (x = 0; x < xcount; x++) + { + dest_y[x] += abase_n[x] * bbase_yn; + } + } + } + } + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_COMPLEX_16)0; + + for (y = 0; y < ycount; y++) + for (n = 0; n < count; n++) + for (x = 0; x < xcount; x++) + /* dest[x,y] += a[x,n] * b[n,y] */ + dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; + } +} + +#endif diff --git a/libgfortran/generated/matmul_c4.c b/libgfortran/generated/matmul_c4.c index 8d13bb91625..8c9a7104ca8 100644 --- a/libgfortran/generated/matmul_c4.c +++ b/libgfortran/generated/matmul_c4.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_4) + /* This is a C version of the following fortran pseudo-code. The key point is the loop order -- we access all arrays column-first, which improves the performance enough to boost galgel spec score by 50%. @@ -215,3 +217,5 @@ matmul_c4 (gfc_array_c4 * retarray, gfc_array_c4 * a, gfc_array_c4 * b) dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } } + +#endif diff --git a/libgfortran/generated/matmul_c8.c b/libgfortran/generated/matmul_c8.c index ada73eb44b0..7b713f1343a 100644 --- a/libgfortran/generated/matmul_c8.c +++ b/libgfortran/generated/matmul_c8.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_8) + /* This is a C version of the following fortran pseudo-code. The key point is the loop order -- we access all arrays column-first, which improves the performance enough to boost galgel spec score by 50%. @@ -215,3 +217,5 @@ matmul_c8 (gfc_array_c8 * retarray, gfc_array_c8 * a, gfc_array_c8 * b) dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } } + +#endif diff --git a/libgfortran/generated/matmul_i16.c b/libgfortran/generated/matmul_i16.c new file mode 100644 index 00000000000..adbfbedaeb2 --- /dev/null +++ b/libgfortran/generated/matmul_i16.c @@ -0,0 +1,221 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_INTEGER_16) + +/* This is a C version of the following fortran pseudo-code. The key + point is the loop order -- we access all arrays column-first, which + improves the performance enough to boost galgel spec score by 50%. + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + C = 0 + DO J=1,N + DO K=1,COUNT + DO I=1,M + C(I,J) = C(I,J)+A(I,K)*B(K,J) +*/ + +extern void matmul_i16 (gfc_array_i16 * retarray, gfc_array_i16 * a, gfc_array_i16 * b); +export_proto(matmul_i16); + +void +matmul_i16 (gfc_array_i16 * retarray, gfc_array_i16 * a, gfc_array_i16 * b) +{ + GFC_INTEGER_16 *abase; + GFC_INTEGER_16 *bbase; + GFC_INTEGER_16 *dest; + + index_type rxstride, rystride, axstride, aystride, bxstride, bystride; + index_type x, y, n, count, xcount, ycount; + + assert (GFC_DESCRIPTOR_RANK (a) == 2 + || GFC_DESCRIPTOR_RANK (b) == 2); + +/* C[xcount,ycount] = A[xcount, count] * B[count,ycount] + + Either A or B (but not both) can be rank 1: + + o One-dimensional argument A is implicitly treated as a row matrix + dimensioned [1,count], so xcount=1. + + o One-dimensional argument B is implicitly treated as a column matrix + dimensioned [count, 1], so ycount=1. + */ + + if (retarray->data == NULL) + { + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[0].stride = 1; + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + } + else + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + + retarray->dim[1].lbound = 0; + retarray->dim[1].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[1].stride = retarray->dim[0].ubound+1; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + + if (GFC_DESCRIPTOR_RANK (retarray) == 1) + { + /* One-dimensional result may be addressed in the code below + either as a row or a column matrix. We want both cases to + work. */ + rxstride = rystride = retarray->dim[0].stride; + } + else + { + rxstride = retarray->dim[0].stride; + rystride = retarray->dim[1].stride; + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = a->dim[0].stride; + aystride = 1; + + xcount = 1; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + } + else + { + axstride = a->dim[0].stride; + aystride = a->dim[1].stride; + + count = a->dim[1].ubound + 1 - a->dim[1].lbound; + xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; + } + + assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = b->dim[0].stride; + + /* bystride should never be used for 1-dimensional b. + in case it is we want it to cause a segfault, rather than + an incorrect result. */ + bystride = 0xDEADBEEF; + ycount = 1; + } + else + { + bxstride = b->dim[0].stride; + bystride = b->dim[1].stride; + ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + GFC_INTEGER_16 *bbase_y; + GFC_INTEGER_16 *dest_y; + GFC_INTEGER_16 *abase_n; + GFC_INTEGER_16 bbase_yn; + + if (rystride == ycount) + memset (dest, 0, (sizeof (GFC_INTEGER_16) * size0((array_t *) retarray))); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_INTEGER_16)0; + } + + for (y = 0; y < ycount; y++) + { + bbase_y = bbase + y*bystride; + dest_y = dest + y*rystride; + for (n = 0; n < count; n++) + { + abase_n = abase + n*aystride; + bbase_yn = bbase_y[n]; + for (x = 0; x < xcount; x++) + { + dest_y[x] += abase_n[x] * bbase_yn; + } + } + } + } + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_INTEGER_16)0; + + for (y = 0; y < ycount; y++) + for (n = 0; n < count; n++) + for (x = 0; x < xcount; x++) + /* dest[x,y] += a[x,n] * b[n,y] */ + dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; + } +} + +#endif diff --git a/libgfortran/generated/matmul_i4.c b/libgfortran/generated/matmul_i4.c index 16c376f2185..abace324d95 100644 --- a/libgfortran/generated/matmul_i4.c +++ b/libgfortran/generated/matmul_i4.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) + /* This is a C version of the following fortran pseudo-code. The key point is the loop order -- we access all arrays column-first, which improves the performance enough to boost galgel spec score by 50%. @@ -215,3 +217,5 @@ matmul_i4 (gfc_array_i4 * retarray, gfc_array_i4 * a, gfc_array_i4 * b) dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } } + +#endif diff --git a/libgfortran/generated/matmul_i8.c b/libgfortran/generated/matmul_i8.c index 0e29d078fa5..9820e405cd0 100644 --- a/libgfortran/generated/matmul_i8.c +++ b/libgfortran/generated/matmul_i8.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) + /* This is a C version of the following fortran pseudo-code. The key point is the loop order -- we access all arrays column-first, which improves the performance enough to boost galgel spec score by 50%. @@ -215,3 +217,5 @@ matmul_i8 (gfc_array_i8 * retarray, gfc_array_i8 * a, gfc_array_i8 * b) dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } } + +#endif diff --git a/libgfortran/generated/matmul_l16.c b/libgfortran/generated/matmul_l16.c new file mode 100644 index 00000000000..28dce3a2422 --- /dev/null +++ b/libgfortran/generated/matmul_l16.c @@ -0,0 +1,196 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_LOGICAL_16) + +/* Dimensions: retarray(x,y) a(x, count) b(count,y). + Either a or b can be rank 1. In this case x or y is 1. */ + +extern void matmul_l16 (gfc_array_l16 *, gfc_array_l4 *, gfc_array_l4 *); +export_proto(matmul_l16); + +void +matmul_l16 (gfc_array_l16 * retarray, gfc_array_l4 * a, gfc_array_l4 * b) +{ + GFC_INTEGER_4 *abase; + GFC_INTEGER_4 *bbase; + GFC_LOGICAL_16 *dest; + index_type rxstride; + index_type rystride; + index_type xcount; + index_type ycount; + index_type xstride; + index_type ystride; + index_type x; + index_type y; + + GFC_INTEGER_4 *pa; + GFC_INTEGER_4 *pb; + index_type astride; + index_type bstride; + index_type count; + index_type n; + + assert (GFC_DESCRIPTOR_RANK (a) == 2 + || GFC_DESCRIPTOR_RANK (b) == 2); + + if (retarray->data == NULL) + { + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[0].stride = 1; + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + } + else + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + + retarray->dim[1].lbound = 0; + retarray->dim[1].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[1].stride = retarray->dim[0].ubound+1; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_LOGICAL_16) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + + abase = a->data; + if (GFC_DESCRIPTOR_SIZE (a) != 4) + { + assert (GFC_DESCRIPTOR_SIZE (a) == 8); + abase = GFOR_POINTER_L8_TO_L4 (abase); + } + bbase = b->data; + if (GFC_DESCRIPTOR_SIZE (b) != 4) + { + assert (GFC_DESCRIPTOR_SIZE (b) == 8); + bbase = GFOR_POINTER_L8_TO_L4 (bbase); + } + dest = retarray->data; + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + + if (GFC_DESCRIPTOR_RANK (retarray) == 1) + { + rxstride = retarray->dim[0].stride; + rystride = rxstride; + } + else + { + rxstride = retarray->dim[0].stride; + rystride = retarray->dim[1].stride; + } + + /* If we have rank 1 parameters, zero the absent stride, and set the size to + one. */ + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + astride = a->dim[0].stride; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + xstride = 0; + rxstride = 0; + xcount = 1; + } + else + { + astride = a->dim[1].stride; + count = a->dim[1].ubound + 1 - a->dim[1].lbound; + xstride = a->dim[0].stride; + xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; + } + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + bstride = b->dim[0].stride; + assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); + ystride = 0; + rystride = 0; + ycount = 1; + } + else + { + bstride = b->dim[0].stride; + assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); + ystride = b->dim[1].stride; + ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; + } + + for (y = 0; y < ycount; y++) + { + for (x = 0; x < xcount; x++) + { + /* Do the summation for this element. For real and integer types + this is the same as DOT_PRODUCT. For complex types we use do + a*b, not conjg(a)*b. */ + pa = abase; + pb = bbase; + *dest = 0; + + for (n = 0; n < count; n++) + { + if (*pa && *pb) + { + *dest = 1; + break; + } + pa += astride; + pb += bstride; + } + + dest += rxstride; + abase += xstride; + } + abase -= xstride * xcount; + bbase += ystride; + dest += rystride - (rxstride * xcount); + } +} + +#endif diff --git a/libgfortran/generated/matmul_l4.c b/libgfortran/generated/matmul_l4.c index ff32eb44fd7..da6681479a5 100644 --- a/libgfortran/generated/matmul_l4.c +++ b/libgfortran/generated/matmul_l4.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_4) + /* Dimensions: retarray(x,y) a(x, count) b(count,y). Either a or b can be rank 1. In this case x or y is 1. */ @@ -190,3 +192,5 @@ matmul_l4 (gfc_array_l4 * retarray, gfc_array_l4 * a, gfc_array_l4 * b) dest += rystride - (rxstride * xcount); } } + +#endif diff --git a/libgfortran/generated/matmul_l8.c b/libgfortran/generated/matmul_l8.c index b726a70d5dc..22c1a660941 100644 --- a/libgfortran/generated/matmul_l8.c +++ b/libgfortran/generated/matmul_l8.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_LOGICAL_8) + /* Dimensions: retarray(x,y) a(x, count) b(count,y). Either a or b can be rank 1. In this case x or y is 1. */ @@ -190,3 +192,5 @@ matmul_l8 (gfc_array_l8 * retarray, gfc_array_l4 * a, gfc_array_l4 * b) dest += rystride - (rxstride * xcount); } } + +#endif diff --git a/libgfortran/generated/matmul_r10.c b/libgfortran/generated/matmul_r10.c new file mode 100644 index 00000000000..8aa342da2f4 --- /dev/null +++ b/libgfortran/generated/matmul_r10.c @@ -0,0 +1,221 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_REAL_10) + +/* This is a C version of the following fortran pseudo-code. The key + point is the loop order -- we access all arrays column-first, which + improves the performance enough to boost galgel spec score by 50%. + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + C = 0 + DO J=1,N + DO K=1,COUNT + DO I=1,M + C(I,J) = C(I,J)+A(I,K)*B(K,J) +*/ + +extern void matmul_r10 (gfc_array_r10 * retarray, gfc_array_r10 * a, gfc_array_r10 * b); +export_proto(matmul_r10); + +void +matmul_r10 (gfc_array_r10 * retarray, gfc_array_r10 * a, gfc_array_r10 * b) +{ + GFC_REAL_10 *abase; + GFC_REAL_10 *bbase; + GFC_REAL_10 *dest; + + index_type rxstride, rystride, axstride, aystride, bxstride, bystride; + index_type x, y, n, count, xcount, ycount; + + assert (GFC_DESCRIPTOR_RANK (a) == 2 + || GFC_DESCRIPTOR_RANK (b) == 2); + +/* C[xcount,ycount] = A[xcount, count] * B[count,ycount] + + Either A or B (but not both) can be rank 1: + + o One-dimensional argument A is implicitly treated as a row matrix + dimensioned [1,count], so xcount=1. + + o One-dimensional argument B is implicitly treated as a column matrix + dimensioned [count, 1], so ycount=1. + */ + + if (retarray->data == NULL) + { + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[0].stride = 1; + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + } + else + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + + retarray->dim[1].lbound = 0; + retarray->dim[1].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[1].stride = retarray->dim[0].ubound+1; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_10) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + + if (GFC_DESCRIPTOR_RANK (retarray) == 1) + { + /* One-dimensional result may be addressed in the code below + either as a row or a column matrix. We want both cases to + work. */ + rxstride = rystride = retarray->dim[0].stride; + } + else + { + rxstride = retarray->dim[0].stride; + rystride = retarray->dim[1].stride; + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = a->dim[0].stride; + aystride = 1; + + xcount = 1; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + } + else + { + axstride = a->dim[0].stride; + aystride = a->dim[1].stride; + + count = a->dim[1].ubound + 1 - a->dim[1].lbound; + xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; + } + + assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = b->dim[0].stride; + + /* bystride should never be used for 1-dimensional b. + in case it is we want it to cause a segfault, rather than + an incorrect result. */ + bystride = 0xDEADBEEF; + ycount = 1; + } + else + { + bxstride = b->dim[0].stride; + bystride = b->dim[1].stride; + ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + GFC_REAL_10 *bbase_y; + GFC_REAL_10 *dest_y; + GFC_REAL_10 *abase_n; + GFC_REAL_10 bbase_yn; + + if (rystride == ycount) + memset (dest, 0, (sizeof (GFC_REAL_10) * size0((array_t *) retarray))); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_REAL_10)0; + } + + for (y = 0; y < ycount; y++) + { + bbase_y = bbase + y*bystride; + dest_y = dest + y*rystride; + for (n = 0; n < count; n++) + { + abase_n = abase + n*aystride; + bbase_yn = bbase_y[n]; + for (x = 0; x < xcount; x++) + { + dest_y[x] += abase_n[x] * bbase_yn; + } + } + } + } + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_REAL_10)0; + + for (y = 0; y < ycount; y++) + for (n = 0; n < count; n++) + for (x = 0; x < xcount; x++) + /* dest[x,y] += a[x,n] * b[n,y] */ + dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; + } +} + +#endif diff --git a/libgfortran/generated/matmul_r16.c b/libgfortran/generated/matmul_r16.c new file mode 100644 index 00000000000..549f39ea6ca --- /dev/null +++ b/libgfortran/generated/matmul_r16.c @@ -0,0 +1,221 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_REAL_16) + +/* This is a C version of the following fortran pseudo-code. The key + point is the loop order -- we access all arrays column-first, which + improves the performance enough to boost galgel spec score by 50%. + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + C = 0 + DO J=1,N + DO K=1,COUNT + DO I=1,M + C(I,J) = C(I,J)+A(I,K)*B(K,J) +*/ + +extern void matmul_r16 (gfc_array_r16 * retarray, gfc_array_r16 * a, gfc_array_r16 * b); +export_proto(matmul_r16); + +void +matmul_r16 (gfc_array_r16 * retarray, gfc_array_r16 * a, gfc_array_r16 * b) +{ + GFC_REAL_16 *abase; + GFC_REAL_16 *bbase; + GFC_REAL_16 *dest; + + index_type rxstride, rystride, axstride, aystride, bxstride, bystride; + index_type x, y, n, count, xcount, ycount; + + assert (GFC_DESCRIPTOR_RANK (a) == 2 + || GFC_DESCRIPTOR_RANK (b) == 2); + +/* C[xcount,ycount] = A[xcount, count] * B[count,ycount] + + Either A or B (but not both) can be rank 1: + + o One-dimensional argument A is implicitly treated as a row matrix + dimensioned [1,count], so xcount=1. + + o One-dimensional argument B is implicitly treated as a column matrix + dimensioned [count, 1], so ycount=1. + */ + + if (retarray->data == NULL) + { + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[0].stride = 1; + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + } + else + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; + retarray->dim[0].stride = 1; + + retarray->dim[1].lbound = 0; + retarray->dim[1].ubound = b->dim[1].ubound - b->dim[1].lbound; + retarray->dim[1].stride = retarray->dim[0].ubound+1; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_16) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + if (a->dim[0].stride == 0) + a->dim[0].stride = 1; + if (b->dim[0].stride == 0) + b->dim[0].stride = 1; + + + if (GFC_DESCRIPTOR_RANK (retarray) == 1) + { + /* One-dimensional result may be addressed in the code below + either as a row or a column matrix. We want both cases to + work. */ + rxstride = rystride = retarray->dim[0].stride; + } + else + { + rxstride = retarray->dim[0].stride; + rystride = retarray->dim[1].stride; + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = a->dim[0].stride; + aystride = 1; + + xcount = 1; + count = a->dim[0].ubound + 1 - a->dim[0].lbound; + } + else + { + axstride = a->dim[0].stride; + aystride = a->dim[1].stride; + + count = a->dim[1].ubound + 1 - a->dim[1].lbound; + xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; + } + + assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = b->dim[0].stride; + + /* bystride should never be used for 1-dimensional b. + in case it is we want it to cause a segfault, rather than + an incorrect result. */ + bystride = 0xDEADBEEF; + ycount = 1; + } + else + { + bxstride = b->dim[0].stride; + bystride = b->dim[1].stride; + ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + GFC_REAL_16 *bbase_y; + GFC_REAL_16 *dest_y; + GFC_REAL_16 *abase_n; + GFC_REAL_16 bbase_yn; + + if (rystride == ycount) + memset (dest, 0, (sizeof (GFC_REAL_16) * size0((array_t *) retarray))); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_REAL_16)0; + } + + for (y = 0; y < ycount; y++) + { + bbase_y = bbase + y*bystride; + dest_y = dest + y*rystride; + for (n = 0; n < count; n++) + { + abase_n = abase + n*aystride; + bbase_yn = bbase_y[n]; + for (x = 0; x < xcount; x++) + { + dest_y[x] += abase_n[x] * bbase_yn; + } + } + } + } + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_REAL_16)0; + + for (y = 0; y < ycount; y++) + for (n = 0; n < count; n++) + for (x = 0; x < xcount; x++) + /* dest[x,y] += a[x,n] * b[n,y] */ + dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; + } +} + +#endif diff --git a/libgfortran/generated/matmul_r4.c b/libgfortran/generated/matmul_r4.c index 91311ceedc8..b1d3eb77c9d 100644 --- a/libgfortran/generated/matmul_r4.c +++ b/libgfortran/generated/matmul_r4.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) + /* This is a C version of the following fortran pseudo-code. The key point is the loop order -- we access all arrays column-first, which improves the performance enough to boost galgel spec score by 50%. @@ -215,3 +217,5 @@ matmul_r4 (gfc_array_r4 * retarray, gfc_array_r4 * a, gfc_array_r4 * b) dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } } + +#endif diff --git a/libgfortran/generated/matmul_r8.c b/libgfortran/generated/matmul_r8.c index 3748731a20f..df9fc3e6a0e 100644 --- a/libgfortran/generated/matmul_r8.c +++ b/libgfortran/generated/matmul_r8.c @@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) + /* This is a C version of the following fortran pseudo-code. The key point is the loop order -- we access all arrays column-first, which improves the performance enough to boost galgel spec score by 50%. @@ -215,3 +217,5 @@ matmul_r8 (gfc_array_r8 * retarray, gfc_array_r8 * a, gfc_array_r8 * b) dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } } + +#endif diff --git a/libgfortran/generated/maxloc0_16_i16.c b/libgfortran/generated/maxloc0_16_i16.c new file mode 100644 index 00000000000..ca934a14d70 --- /dev/null +++ b/libgfortran/generated/maxloc0_16_i16.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_i16 (gfc_array_i16 * retarray, gfc_array_i16 *array); +export_proto(maxloc0_16_i16); + +void +maxloc0_16_i16 (gfc_array_i16 * retarray, gfc_array_i16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 maxval; + + maxval = -GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_16_i16 (gfc_array_i16 *, gfc_array_i16 *, gfc_array_l4 *); +export_proto(mmaxloc0_16_i16); + +void +mmaxloc0_16_i16 (gfc_array_i16 * retarray, gfc_array_i16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 maxval; + + maxval = -GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_16_i4.c b/libgfortran/generated/maxloc0_16_i4.c new file mode 100644 index 00000000000..9dcd7b48a50 --- /dev/null +++ b/libgfortran/generated/maxloc0_16_i4.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_i4 (gfc_array_i16 * retarray, gfc_array_i4 *array); +export_proto(maxloc0_16_i4); + +void +maxloc0_16_i4 (gfc_array_i16 * retarray, gfc_array_i4 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_4 maxval; + + maxval = -GFC_INTEGER_4_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_16_i4 (gfc_array_i16 *, gfc_array_i4 *, gfc_array_l4 *); +export_proto(mmaxloc0_16_i4); + +void +mmaxloc0_16_i4 (gfc_array_i16 * retarray, gfc_array_i4 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_INTEGER_4 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_4 maxval; + + maxval = -GFC_INTEGER_4_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_16_i8.c b/libgfortran/generated/maxloc0_16_i8.c new file mode 100644 index 00000000000..d8a6261ea44 --- /dev/null +++ b/libgfortran/generated/maxloc0_16_i8.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_i8 (gfc_array_i16 * retarray, gfc_array_i8 *array); +export_proto(maxloc0_16_i8); + +void +maxloc0_16_i8 (gfc_array_i16 * retarray, gfc_array_i8 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_8 maxval; + + maxval = -GFC_INTEGER_8_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_16_i8 (gfc_array_i16 *, gfc_array_i8 *, gfc_array_l4 *); +export_proto(mmaxloc0_16_i8); + +void +mmaxloc0_16_i8 (gfc_array_i16 * retarray, gfc_array_i8 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_INTEGER_8 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_8 maxval; + + maxval = -GFC_INTEGER_8_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_16_r10.c b/libgfortran/generated/maxloc0_16_r10.c new file mode 100644 index 00000000000..1f0dfb0383e --- /dev/null +++ b/libgfortran/generated/maxloc0_16_r10.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_r10 (gfc_array_i16 * retarray, gfc_array_r10 *array); +export_proto(maxloc0_16_r10); + +void +maxloc0_16_r10 (gfc_array_i16 * retarray, gfc_array_r10 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_10 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 maxval; + + maxval = -GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_16_r10 (gfc_array_i16 *, gfc_array_r10 *, gfc_array_l4 *); +export_proto(mmaxloc0_16_r10); + +void +mmaxloc0_16_r10 (gfc_array_i16 * retarray, gfc_array_r10 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 maxval; + + maxval = -GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_16_r16.c b/libgfortran/generated/maxloc0_16_r16.c new file mode 100644 index 00000000000..d9e3780470c --- /dev/null +++ b/libgfortran/generated/maxloc0_16_r16.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_r16 (gfc_array_i16 * retarray, gfc_array_r16 *array); +export_proto(maxloc0_16_r16); + +void +maxloc0_16_r16 (gfc_array_i16 * retarray, gfc_array_r16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 maxval; + + maxval = -GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_16_r16 (gfc_array_i16 *, gfc_array_r16 *, gfc_array_l4 *); +export_proto(mmaxloc0_16_r16); + +void +mmaxloc0_16_r16 (gfc_array_i16 * retarray, gfc_array_r16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 maxval; + + maxval = -GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_16_r4.c b/libgfortran/generated/maxloc0_16_r4.c new file mode 100644 index 00000000000..6e0e92aa372 --- /dev/null +++ b/libgfortran/generated/maxloc0_16_r4.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_r4 (gfc_array_i16 * retarray, gfc_array_r4 *array); +export_proto(maxloc0_16_r4); + +void +maxloc0_16_r4 (gfc_array_i16 * retarray, gfc_array_r4 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_4 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_4 maxval; + + maxval = -GFC_REAL_4_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_16_r4 (gfc_array_i16 *, gfc_array_r4 *, gfc_array_l4 *); +export_proto(mmaxloc0_16_r4); + +void +mmaxloc0_16_r4 (gfc_array_i16 * retarray, gfc_array_r4 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_REAL_4 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_4 maxval; + + maxval = -GFC_REAL_4_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_16_r8.c b/libgfortran/generated/maxloc0_16_r8.c new file mode 100644 index 00000000000..878e21e1e16 --- /dev/null +++ b/libgfortran/generated/maxloc0_16_r8.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_r8 (gfc_array_i16 * retarray, gfc_array_r8 *array); +export_proto(maxloc0_16_r8); + +void +maxloc0_16_r8 (gfc_array_i16 * retarray, gfc_array_r8 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_8 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_8 maxval; + + maxval = -GFC_REAL_8_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_16_r8 (gfc_array_i16 *, gfc_array_r8 *, gfc_array_l4 *); +export_proto(mmaxloc0_16_r8); + +void +mmaxloc0_16_r8 (gfc_array_i16 * retarray, gfc_array_r8 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_REAL_8 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_8 maxval; + + maxval = -GFC_REAL_8_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_4_i16.c b/libgfortran/generated/maxloc0_4_i16.c new file mode 100644 index 00000000000..e41953010aa --- /dev/null +++ b/libgfortran/generated/maxloc0_4_i16.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_i16 (gfc_array_i4 * retarray, gfc_array_i16 *array); +export_proto(maxloc0_4_i16); + +void +maxloc0_4_i16 (gfc_array_i4 * retarray, gfc_array_i16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 maxval; + + maxval = -GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_4_i16 (gfc_array_i4 *, gfc_array_i16 *, gfc_array_l4 *); +export_proto(mmaxloc0_4_i16); + +void +mmaxloc0_4_i16 (gfc_array_i4 * retarray, gfc_array_i16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 maxval; + + maxval = -GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_4_i4.c b/libgfortran/generated/maxloc0_4_i4.c index 5821e38ef22..d88212411cf 100644 --- a/libgfortran/generated/maxloc0_4_i4.c +++ b/libgfortran/generated/maxloc0_4_i4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + extern void maxloc0_4_i4 (gfc_array_i4 * retarray, gfc_array_i4 *array); export_proto(maxloc0_4_i4); @@ -286,3 +288,5 @@ mmaxloc0_4_i4 (gfc_array_i4 * retarray, gfc_array_i4 *array, } } } + +#endif diff --git a/libgfortran/generated/maxloc0_4_i8.c b/libgfortran/generated/maxloc0_4_i8.c index ae935666d18..e709d8308f1 100644 --- a/libgfortran/generated/maxloc0_4_i8.c +++ b/libgfortran/generated/maxloc0_4_i8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) + extern void maxloc0_4_i8 (gfc_array_i4 * retarray, gfc_array_i8 *array); export_proto(maxloc0_4_i8); @@ -286,3 +288,5 @@ mmaxloc0_4_i8 (gfc_array_i4 * retarray, gfc_array_i8 *array, } } } + +#endif diff --git a/libgfortran/generated/maxloc0_4_r10.c b/libgfortran/generated/maxloc0_4_r10.c new file mode 100644 index 00000000000..63b4ab3b345 --- /dev/null +++ b/libgfortran/generated/maxloc0_4_r10.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_r10 (gfc_array_i4 * retarray, gfc_array_r10 *array); +export_proto(maxloc0_4_r10); + +void +maxloc0_4_r10 (gfc_array_i4 * retarray, gfc_array_r10 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_10 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 maxval; + + maxval = -GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_4_r10 (gfc_array_i4 *, gfc_array_r10 *, gfc_array_l4 *); +export_proto(mmaxloc0_4_r10); + +void +mmaxloc0_4_r10 (gfc_array_i4 * retarray, gfc_array_r10 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 maxval; + + maxval = -GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_4_r16.c b/libgfortran/generated/maxloc0_4_r16.c new file mode 100644 index 00000000000..41cecafe38a --- /dev/null +++ b/libgfortran/generated/maxloc0_4_r16.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_r16 (gfc_array_i4 * retarray, gfc_array_r16 *array); +export_proto(maxloc0_4_r16); + +void +maxloc0_4_r16 (gfc_array_i4 * retarray, gfc_array_r16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_16 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 maxval; + + maxval = -GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_4_r16 (gfc_array_i4 *, gfc_array_r16 *, gfc_array_l4 *); +export_proto(mmaxloc0_4_r16); + +void +mmaxloc0_4_r16 (gfc_array_i4 * retarray, gfc_array_r16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 maxval; + + maxval = -GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_4_r4.c b/libgfortran/generated/maxloc0_4_r4.c index a5e8c741e0d..3eba4f2cc24 100644 --- a/libgfortran/generated/maxloc0_4_r4.c +++ b/libgfortran/generated/maxloc0_4_r4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) + extern void maxloc0_4_r4 (gfc_array_i4 * retarray, gfc_array_r4 *array); export_proto(maxloc0_4_r4); @@ -286,3 +288,5 @@ mmaxloc0_4_r4 (gfc_array_i4 * retarray, gfc_array_r4 *array, } } } + +#endif diff --git a/libgfortran/generated/maxloc0_4_r8.c b/libgfortran/generated/maxloc0_4_r8.c index e1ac5d7b9f6..3a5f3f2d38a 100644 --- a/libgfortran/generated/maxloc0_4_r8.c +++ b/libgfortran/generated/maxloc0_4_r8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) + extern void maxloc0_4_r8 (gfc_array_i4 * retarray, gfc_array_r8 *array); export_proto(maxloc0_4_r8); @@ -286,3 +288,5 @@ mmaxloc0_4_r8 (gfc_array_i4 * retarray, gfc_array_r8 *array, } } } + +#endif diff --git a/libgfortran/generated/maxloc0_8_i16.c b/libgfortran/generated/maxloc0_8_i16.c new file mode 100644 index 00000000000..52316ed0850 --- /dev/null +++ b/libgfortran/generated/maxloc0_8_i16.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_i16 (gfc_array_i8 * retarray, gfc_array_i16 *array); +export_proto(maxloc0_8_i16); + +void +maxloc0_8_i16 (gfc_array_i8 * retarray, gfc_array_i16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 maxval; + + maxval = -GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_8_i16 (gfc_array_i8 *, gfc_array_i16 *, gfc_array_l4 *); +export_proto(mmaxloc0_8_i16); + +void +mmaxloc0_8_i16 (gfc_array_i8 * retarray, gfc_array_i16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 maxval; + + maxval = -GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_8_i4.c b/libgfortran/generated/maxloc0_8_i4.c index 13720778c6d..aa37b6d1f38 100644 --- a/libgfortran/generated/maxloc0_8_i4.c +++ b/libgfortran/generated/maxloc0_8_i4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) + extern void maxloc0_8_i4 (gfc_array_i8 * retarray, gfc_array_i4 *array); export_proto(maxloc0_8_i4); @@ -286,3 +288,5 @@ mmaxloc0_8_i4 (gfc_array_i8 * retarray, gfc_array_i4 *array, } } } + +#endif diff --git a/libgfortran/generated/maxloc0_8_i8.c b/libgfortran/generated/maxloc0_8_i8.c index 83d17cc3d02..8c825c4a45a 100644 --- a/libgfortran/generated/maxloc0_8_i8.c +++ b/libgfortran/generated/maxloc0_8_i8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + extern void maxloc0_8_i8 (gfc_array_i8 * retarray, gfc_array_i8 *array); export_proto(maxloc0_8_i8); @@ -286,3 +288,5 @@ mmaxloc0_8_i8 (gfc_array_i8 * retarray, gfc_array_i8 *array, } } } + +#endif diff --git a/libgfortran/generated/maxloc0_8_r10.c b/libgfortran/generated/maxloc0_8_r10.c new file mode 100644 index 00000000000..6add1779ef1 --- /dev/null +++ b/libgfortran/generated/maxloc0_8_r10.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_r10 (gfc_array_i8 * retarray, gfc_array_r10 *array); +export_proto(maxloc0_8_r10); + +void +maxloc0_8_r10 (gfc_array_i8 * retarray, gfc_array_r10 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_10 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 maxval; + + maxval = -GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_8_r10 (gfc_array_i8 *, gfc_array_r10 *, gfc_array_l4 *); +export_proto(mmaxloc0_8_r10); + +void +mmaxloc0_8_r10 (gfc_array_i8 * retarray, gfc_array_r10 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 maxval; + + maxval = -GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_8_r16.c b/libgfortran/generated/maxloc0_8_r16.c new file mode 100644 index 00000000000..92f0884f7a5 --- /dev/null +++ b/libgfortran/generated/maxloc0_8_r16.c @@ -0,0 +1,292 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_r16 (gfc_array_i8 * retarray, gfc_array_r16 *array); +export_proto(maxloc0_8_r16); + +void +maxloc0_8_r16 (gfc_array_i8 * retarray, gfc_array_r16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_16 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 maxval; + + maxval = -GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mmaxloc0_8_r16 (gfc_array_i8 *, gfc_array_r16 *, gfc_array_l4 *); +export_proto(mmaxloc0_8_r16); + +void +mmaxloc0_8_r16 (gfc_array_i8 * retarray, gfc_array_r16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 maxval; + + maxval = -GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_8_r4.c b/libgfortran/generated/maxloc0_8_r4.c index 8eede406215..07cebb37702 100644 --- a/libgfortran/generated/maxloc0_8_r4.c +++ b/libgfortran/generated/maxloc0_8_r4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) + extern void maxloc0_8_r4 (gfc_array_i8 * retarray, gfc_array_r4 *array); export_proto(maxloc0_8_r4); @@ -286,3 +288,5 @@ mmaxloc0_8_r4 (gfc_array_i8 * retarray, gfc_array_r4 *array, } } } + +#endif diff --git a/libgfortran/generated/maxloc0_8_r8.c b/libgfortran/generated/maxloc0_8_r8.c index 55ed45fe513..92f2805a5b2 100644 --- a/libgfortran/generated/maxloc0_8_r8.c +++ b/libgfortran/generated/maxloc0_8_r8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) + extern void maxloc0_8_r8 (gfc_array_i8 * retarray, gfc_array_r8 *array); export_proto(maxloc0_8_r8); @@ -286,3 +288,5 @@ mmaxloc0_8_r8 (gfc_array_i8 * retarray, gfc_array_r8 *array, } } } + +#endif diff --git a/libgfortran/generated/maxloc1_16_i16.c b/libgfortran/generated/maxloc1_16_i16.c new file mode 100644 index 00000000000..d9666bdbe1b --- /dev/null +++ b/libgfortran/generated/maxloc1_16_i16.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *); +export_proto(maxloc1_16_i16); + +void +maxloc1_16_i16 (gfc_array_i16 *retarray, gfc_array_i16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_16 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_16 maxval; + maxval = -GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_16_i16); + +void +mmaxloc1_16_i16 (gfc_array_i16 * retarray, gfc_array_i16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 maxval; + maxval = -GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_16_i4.c b/libgfortran/generated/maxloc1_16_i4.c new file mode 100644 index 00000000000..9df85ec107a --- /dev/null +++ b/libgfortran/generated/maxloc1_16_i4.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_i4 (gfc_array_i16 *, gfc_array_i4 *, index_type *); +export_proto(maxloc1_16_i4); + +void +maxloc1_16_i4 (gfc_array_i16 *retarray, gfc_array_i4 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_4 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_4 maxval; + maxval = -GFC_INTEGER_4_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_i4 (gfc_array_i16 *, gfc_array_i4 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_16_i4); + +void +mmaxloc1_16_i4 (gfc_array_i16 * retarray, gfc_array_i4 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_INTEGER_4 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_4 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_4 maxval; + maxval = -GFC_INTEGER_4_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_16_i8.c b/libgfortran/generated/maxloc1_16_i8.c new file mode 100644 index 00000000000..8d6e003f383 --- /dev/null +++ b/libgfortran/generated/maxloc1_16_i8.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_i8 (gfc_array_i16 *, gfc_array_i8 *, index_type *); +export_proto(maxloc1_16_i8); + +void +maxloc1_16_i8 (gfc_array_i16 *retarray, gfc_array_i8 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_8 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_8 maxval; + maxval = -GFC_INTEGER_8_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_i8 (gfc_array_i16 *, gfc_array_i8 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_16_i8); + +void +mmaxloc1_16_i8 (gfc_array_i16 * retarray, gfc_array_i8 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_INTEGER_8 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_8 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_8 maxval; + maxval = -GFC_INTEGER_8_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_16_r10.c b/libgfortran/generated/maxloc1_16_r10.c new file mode 100644 index 00000000000..64b277005ac --- /dev/null +++ b/libgfortran/generated/maxloc1_16_r10.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_r10 (gfc_array_i16 *, gfc_array_r10 *, index_type *); +export_proto(maxloc1_16_r10); + +void +maxloc1_16_r10 (gfc_array_i16 *retarray, gfc_array_r10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_10 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_10 maxval; + maxval = -GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_r10 (gfc_array_i16 *, gfc_array_r10 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_16_r10); + +void +mmaxloc1_16_r10 (gfc_array_i16 * retarray, gfc_array_r10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 maxval; + maxval = -GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_16_r16.c b/libgfortran/generated/maxloc1_16_r16.c new file mode 100644 index 00000000000..f6718083f5c --- /dev/null +++ b/libgfortran/generated/maxloc1_16_r16.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_r16 (gfc_array_i16 *, gfc_array_r16 *, index_type *); +export_proto(maxloc1_16_r16); + +void +maxloc1_16_r16 (gfc_array_i16 *retarray, gfc_array_r16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_16 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_16 maxval; + maxval = -GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_r16 (gfc_array_i16 *, gfc_array_r16 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_16_r16); + +void +mmaxloc1_16_r16 (gfc_array_i16 * retarray, gfc_array_r16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 maxval; + maxval = -GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_16_r4.c b/libgfortran/generated/maxloc1_16_r4.c new file mode 100644 index 00000000000..902e97c994e --- /dev/null +++ b/libgfortran/generated/maxloc1_16_r4.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_r4 (gfc_array_i16 *, gfc_array_r4 *, index_type *); +export_proto(maxloc1_16_r4); + +void +maxloc1_16_r4 (gfc_array_i16 *retarray, gfc_array_r4 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_4 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_4 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_4 maxval; + maxval = -GFC_REAL_4_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_r4 (gfc_array_i16 *, gfc_array_r4 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_16_r4); + +void +mmaxloc1_16_r4 (gfc_array_i16 * retarray, gfc_array_r4 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_REAL_4 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_4 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_4 maxval; + maxval = -GFC_REAL_4_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_16_r8.c b/libgfortran/generated/maxloc1_16_r8.c new file mode 100644 index 00000000000..3e28d6706e2 --- /dev/null +++ b/libgfortran/generated/maxloc1_16_r8.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_r8 (gfc_array_i16 *, gfc_array_r8 *, index_type *); +export_proto(maxloc1_16_r8); + +void +maxloc1_16_r8 (gfc_array_i16 *retarray, gfc_array_r8 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_8 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_8 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_8 maxval; + maxval = -GFC_REAL_8_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_r8 (gfc_array_i16 *, gfc_array_r8 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_16_r8); + +void +mmaxloc1_16_r8 (gfc_array_i16 * retarray, gfc_array_r8 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_REAL_8 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_8 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_8 maxval; + maxval = -GFC_REAL_8_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_i16.c b/libgfortran/generated/maxloc1_4_i16.c new file mode 100644 index 00000000000..8ca2cf1195b --- /dev/null +++ b/libgfortran/generated/maxloc1_4_i16.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_i16 (gfc_array_i4 *, gfc_array_i16 *, index_type *); +export_proto(maxloc1_4_i16); + +void +maxloc1_4_i16 (gfc_array_i4 *retarray, gfc_array_i16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_16 *src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_16 maxval; + maxval = -GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_i16 (gfc_array_i4 *, gfc_array_i16 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_4_i16); + +void +mmaxloc1_4_i16 (gfc_array_i4 * retarray, gfc_array_i16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 maxval; + maxval = -GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_i4.c b/libgfortran/generated/maxloc1_4_i4.c index bfa721d4da2..06a657cca4e 100644 --- a/libgfortran/generated/maxloc1_4_i4.c +++ b/libgfortran/generated/maxloc1_4_i4.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + extern void maxloc1_4_i4 (gfc_array_i4 *, gfc_array_i4 *, index_type *); export_proto(maxloc1_4_i4); @@ -341,3 +344,4 @@ mmaxloc1_4_i4 (gfc_array_i4 * retarray, gfc_array_i4 * array, } } +#endif diff --git a/libgfortran/generated/maxloc1_4_i8.c b/libgfortran/generated/maxloc1_4_i8.c index 81a09ba6b44..f03b36ca6a6 100644 --- a/libgfortran/generated/maxloc1_4_i8.c +++ b/libgfortran/generated/maxloc1_4_i8.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) + + extern void maxloc1_4_i8 (gfc_array_i4 *, gfc_array_i8 *, index_type *); export_proto(maxloc1_4_i8); @@ -341,3 +344,4 @@ mmaxloc1_4_i8 (gfc_array_i4 * retarray, gfc_array_i8 * array, } } +#endif diff --git a/libgfortran/generated/maxloc1_4_r10.c b/libgfortran/generated/maxloc1_4_r10.c new file mode 100644 index 00000000000..854b0b8042e --- /dev/null +++ b/libgfortran/generated/maxloc1_4_r10.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_r10 (gfc_array_i4 *, gfc_array_r10 *, index_type *); +export_proto(maxloc1_4_r10); + +void +maxloc1_4_r10 (gfc_array_i4 *retarray, gfc_array_r10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_10 *src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_10 maxval; + maxval = -GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_r10 (gfc_array_i4 *, gfc_array_r10 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_4_r10); + +void +mmaxloc1_4_r10 (gfc_array_i4 * retarray, gfc_array_r10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 maxval; + maxval = -GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_r16.c b/libgfortran/generated/maxloc1_4_r16.c new file mode 100644 index 00000000000..fdabd1ae4f2 --- /dev/null +++ b/libgfortran/generated/maxloc1_4_r16.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_r16 (gfc_array_i4 *, gfc_array_r16 *, index_type *); +export_proto(maxloc1_4_r16); + +void +maxloc1_4_r16 (gfc_array_i4 *retarray, gfc_array_r16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_16 *src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_16 maxval; + maxval = -GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_r16 (gfc_array_i4 *, gfc_array_r16 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_4_r16); + +void +mmaxloc1_4_r16 (gfc_array_i4 * retarray, gfc_array_r16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 maxval; + maxval = -GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_r4.c b/libgfortran/generated/maxloc1_4_r4.c index d955b7756a0..34510e7de1a 100644 --- a/libgfortran/generated/maxloc1_4_r4.c +++ b/libgfortran/generated/maxloc1_4_r4.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) + + extern void maxloc1_4_r4 (gfc_array_i4 *, gfc_array_r4 *, index_type *); export_proto(maxloc1_4_r4); @@ -341,3 +344,4 @@ mmaxloc1_4_r4 (gfc_array_i4 * retarray, gfc_array_r4 * array, } } +#endif diff --git a/libgfortran/generated/maxloc1_4_r8.c b/libgfortran/generated/maxloc1_4_r8.c index c2a2ec4df8f..ea67079c6c0 100644 --- a/libgfortran/generated/maxloc1_4_r8.c +++ b/libgfortran/generated/maxloc1_4_r8.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) + + extern void maxloc1_4_r8 (gfc_array_i4 *, gfc_array_r8 *, index_type *); export_proto(maxloc1_4_r8); @@ -341,3 +344,4 @@ mmaxloc1_4_r8 (gfc_array_i4 * retarray, gfc_array_r8 * array, } } +#endif diff --git a/libgfortran/generated/maxloc1_8_i16.c b/libgfortran/generated/maxloc1_8_i16.c new file mode 100644 index 00000000000..f3ba50b32c3 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_i16.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_i16 (gfc_array_i8 *, gfc_array_i16 *, index_type *); +export_proto(maxloc1_8_i16); + +void +maxloc1_8_i16 (gfc_array_i8 *retarray, gfc_array_i16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_16 *src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_16 maxval; + maxval = -GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_i16 (gfc_array_i8 *, gfc_array_i16 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_8_i16); + +void +mmaxloc1_8_i16 (gfc_array_i8 * retarray, gfc_array_i16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 maxval; + maxval = -GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_i4.c b/libgfortran/generated/maxloc1_8_i4.c index 344c13b2fbe..1c095ff7bb9 100644 --- a/libgfortran/generated/maxloc1_8_i4.c +++ b/libgfortran/generated/maxloc1_8_i4.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) + + extern void maxloc1_8_i4 (gfc_array_i8 *, gfc_array_i4 *, index_type *); export_proto(maxloc1_8_i4); @@ -341,3 +344,4 @@ mmaxloc1_8_i4 (gfc_array_i8 * retarray, gfc_array_i4 * array, } } +#endif diff --git a/libgfortran/generated/maxloc1_8_i8.c b/libgfortran/generated/maxloc1_8_i8.c index 763667bb3ab..ee6d269f307 100644 --- a/libgfortran/generated/maxloc1_8_i8.c +++ b/libgfortran/generated/maxloc1_8_i8.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + extern void maxloc1_8_i8 (gfc_array_i8 *, gfc_array_i8 *, index_type *); export_proto(maxloc1_8_i8); @@ -341,3 +344,4 @@ mmaxloc1_8_i8 (gfc_array_i8 * retarray, gfc_array_i8 * array, } } +#endif diff --git a/libgfortran/generated/maxloc1_8_r10.c b/libgfortran/generated/maxloc1_8_r10.c new file mode 100644 index 00000000000..67c77330142 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_r10.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_r10 (gfc_array_i8 *, gfc_array_r10 *, index_type *); +export_proto(maxloc1_8_r10); + +void +maxloc1_8_r10 (gfc_array_i8 *retarray, gfc_array_r10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_10 *src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_10 maxval; + maxval = -GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_r10 (gfc_array_i8 *, gfc_array_r10 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_8_r10); + +void +mmaxloc1_8_r10 (gfc_array_i8 * retarray, gfc_array_r10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 maxval; + maxval = -GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_r16.c b/libgfortran/generated/maxloc1_8_r16.c new file mode 100644 index 00000000000..d0b607f25dc --- /dev/null +++ b/libgfortran/generated/maxloc1_8_r16.c @@ -0,0 +1,347 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_r16 (gfc_array_i8 *, gfc_array_r16 *, index_type *); +export_proto(maxloc1_8_r16); + +void +maxloc1_8_r16 (gfc_array_i8 *retarray, gfc_array_r16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_16 *src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_16 maxval; + maxval = -GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_r16 (gfc_array_i8 *, gfc_array_r16 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxloc1_8_r16); + +void +mmaxloc1_8_r16 (gfc_array_i8 * retarray, gfc_array_r16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 maxval; + maxval = -GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_r4.c b/libgfortran/generated/maxloc1_8_r4.c index 8de42dfed95..a7dd5ca1c0e 100644 --- a/libgfortran/generated/maxloc1_8_r4.c +++ b/libgfortran/generated/maxloc1_8_r4.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) + + extern void maxloc1_8_r4 (gfc_array_i8 *, gfc_array_r4 *, index_type *); export_proto(maxloc1_8_r4); @@ -341,3 +344,4 @@ mmaxloc1_8_r4 (gfc_array_i8 * retarray, gfc_array_r4 * array, } } +#endif diff --git a/libgfortran/generated/maxloc1_8_r8.c b/libgfortran/generated/maxloc1_8_r8.c index 8b22fdb7cbc..188a4105a5c 100644 --- a/libgfortran/generated/maxloc1_8_r8.c +++ b/libgfortran/generated/maxloc1_8_r8.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) + + extern void maxloc1_8_r8 (gfc_array_i8 *, gfc_array_r8 *, index_type *); export_proto(maxloc1_8_r8); @@ -341,3 +344,4 @@ mmaxloc1_8_r8 (gfc_array_i8 * retarray, gfc_array_r8 * array, } } +#endif diff --git a/libgfortran/generated/maxval_i16.c b/libgfortran/generated/maxval_i16.c new file mode 100644 index 00000000000..cdcfe020727 --- /dev/null +++ b/libgfortran/generated/maxval_i16.c @@ -0,0 +1,336 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxval_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *); +export_proto(maxval_i16); + +void +maxval_i16 (gfc_array_i16 *retarray, gfc_array_i16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_16 *src; + GFC_INTEGER_16 result; + src = base; + { + + result = -GFC_INTEGER_16_HUGE; + if (len <= 0) + *dest = -GFC_INTEGER_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxval_i16); + +void +mmaxval_i16 (gfc_array_i16 * retarray, gfc_array_i16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + result = -GFC_INTEGER_16_HUGE; + if (len <= 0) + *dest = -GFC_INTEGER_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_i4.c b/libgfortran/generated/maxval_i4.c index 2c82e335fa0..5f1ba4d65b1 100644 --- a/libgfortran/generated/maxval_i4.c +++ b/libgfortran/generated/maxval_i4.c @@ -35,6 +35,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + extern void maxval_i4 (gfc_array_i4 *, gfc_array_i4 *, index_type *); export_proto(maxval_i4); @@ -330,3 +333,4 @@ mmaxval_i4 (gfc_array_i4 * retarray, gfc_array_i4 * array, } } +#endif diff --git a/libgfortran/generated/maxval_i8.c b/libgfortran/generated/maxval_i8.c index 94103261114..f1d16f3b389 100644 --- a/libgfortran/generated/maxval_i8.c +++ b/libgfortran/generated/maxval_i8.c @@ -35,6 +35,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + extern void maxval_i8 (gfc_array_i8 *, gfc_array_i8 *, index_type *); export_proto(maxval_i8); @@ -330,3 +333,4 @@ mmaxval_i8 (gfc_array_i8 * retarray, gfc_array_i8 * array, } } +#endif diff --git a/libgfortran/generated/maxval_r10.c b/libgfortran/generated/maxval_r10.c new file mode 100644 index 00000000000..07c7d7d462a --- /dev/null +++ b/libgfortran/generated/maxval_r10.c @@ -0,0 +1,336 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) + + +extern void maxval_r10 (gfc_array_r10 *, gfc_array_r10 *, index_type *); +export_proto(maxval_r10); + +void +maxval_r10 (gfc_array_r10 *retarray, gfc_array_r10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *base; + GFC_REAL_10 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_10 *src; + GFC_REAL_10 result; + src = base; + { + + result = -GFC_REAL_10_HUGE; + if (len <= 0) + *dest = -GFC_REAL_10_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_r10 (gfc_array_r10 *, gfc_array_r10 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxval_r10); + +void +mmaxval_r10 (gfc_array_r10 * retarray, gfc_array_r10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_REAL_10 result; + src = base; + msrc = mbase; + { + + result = -GFC_REAL_10_HUGE; + if (len <= 0) + *dest = -GFC_REAL_10_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_r16.c b/libgfortran/generated/maxval_r16.c new file mode 100644 index 00000000000..0f8f246fb17 --- /dev/null +++ b/libgfortran/generated/maxval_r16.c @@ -0,0 +1,336 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) + + +extern void maxval_r16 (gfc_array_r16 *, gfc_array_r16 *, index_type *); +export_proto(maxval_r16); + +void +maxval_r16 (gfc_array_r16 *retarray, gfc_array_r16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *base; + GFC_REAL_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_16 *src; + GFC_REAL_16 result; + src = base; + { + + result = -GFC_REAL_16_HUGE; + if (len <= 0) + *dest = -GFC_REAL_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src > result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_r16 (gfc_array_r16 *, gfc_array_r16 *, index_type *, + gfc_array_l4 *); +export_proto(mmaxval_r16); + +void +mmaxval_r16 (gfc_array_r16 * retarray, gfc_array_r16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_REAL_16 result; + src = base; + msrc = mbase; + { + + result = -GFC_REAL_16_HUGE; + if (len <= 0) + *dest = -GFC_REAL_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src > result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_r4.c b/libgfortran/generated/maxval_r4.c index 6e4236caebd..4d56bbf5b16 100644 --- a/libgfortran/generated/maxval_r4.c +++ b/libgfortran/generated/maxval_r4.c @@ -35,6 +35,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) + + extern void maxval_r4 (gfc_array_r4 *, gfc_array_r4 *, index_type *); export_proto(maxval_r4); @@ -330,3 +333,4 @@ mmaxval_r4 (gfc_array_r4 * retarray, gfc_array_r4 * array, } } +#endif diff --git a/libgfortran/generated/maxval_r8.c b/libgfortran/generated/maxval_r8.c index 2d8eb2d6299..d84e18ccd0c 100644 --- a/libgfortran/generated/maxval_r8.c +++ b/libgfortran/generated/maxval_r8.c @@ -35,6 +35,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) + + extern void maxval_r8 (gfc_array_r8 *, gfc_array_r8 *, index_type *); export_proto(maxval_r8); @@ -330,3 +333,4 @@ mmaxval_r8 (gfc_array_r8 * retarray, gfc_array_r8 * array, } } +#endif diff --git a/libgfortran/generated/minloc0_16_i16.c b/libgfortran/generated/minloc0_16_i16.c new file mode 100644 index 00000000000..af097faad01 --- /dev/null +++ b/libgfortran/generated/minloc0_16_i16.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_i16 (gfc_array_i16 * retarray, gfc_array_i16 *array); +export_proto(minloc0_16_i16); + +void +minloc0_16_i16 (gfc_array_i16 * retarray, gfc_array_i16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 minval; + + minval = GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_16_i16 (gfc_array_i16 *, gfc_array_i16 *, gfc_array_l4 *); +export_proto(mminloc0_16_i16); + +void +mminloc0_16_i16 (gfc_array_i16 * retarray, gfc_array_i16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 minval; + + minval = GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_16_i4.c b/libgfortran/generated/minloc0_16_i4.c new file mode 100644 index 00000000000..156938158fe --- /dev/null +++ b/libgfortran/generated/minloc0_16_i4.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_i4 (gfc_array_i16 * retarray, gfc_array_i4 *array); +export_proto(minloc0_16_i4); + +void +minloc0_16_i4 (gfc_array_i16 * retarray, gfc_array_i4 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_4 minval; + + minval = GFC_INTEGER_4_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_16_i4 (gfc_array_i16 *, gfc_array_i4 *, gfc_array_l4 *); +export_proto(mminloc0_16_i4); + +void +mminloc0_16_i4 (gfc_array_i16 * retarray, gfc_array_i4 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_INTEGER_4 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_4 minval; + + minval = GFC_INTEGER_4_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_16_i8.c b/libgfortran/generated/minloc0_16_i8.c new file mode 100644 index 00000000000..57af8927c5b --- /dev/null +++ b/libgfortran/generated/minloc0_16_i8.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_i8 (gfc_array_i16 * retarray, gfc_array_i8 *array); +export_proto(minloc0_16_i8); + +void +minloc0_16_i8 (gfc_array_i16 * retarray, gfc_array_i8 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_8 minval; + + minval = GFC_INTEGER_8_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_16_i8 (gfc_array_i16 *, gfc_array_i8 *, gfc_array_l4 *); +export_proto(mminloc0_16_i8); + +void +mminloc0_16_i8 (gfc_array_i16 * retarray, gfc_array_i8 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_INTEGER_8 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_8 minval; + + minval = GFC_INTEGER_8_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_16_r10.c b/libgfortran/generated/minloc0_16_r10.c new file mode 100644 index 00000000000..58ed79d5fef --- /dev/null +++ b/libgfortran/generated/minloc0_16_r10.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_r10 (gfc_array_i16 * retarray, gfc_array_r10 *array); +export_proto(minloc0_16_r10); + +void +minloc0_16_r10 (gfc_array_i16 * retarray, gfc_array_r10 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_10 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 minval; + + minval = GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_16_r10 (gfc_array_i16 *, gfc_array_r10 *, gfc_array_l4 *); +export_proto(mminloc0_16_r10); + +void +mminloc0_16_r10 (gfc_array_i16 * retarray, gfc_array_r10 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 minval; + + minval = GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_16_r16.c b/libgfortran/generated/minloc0_16_r16.c new file mode 100644 index 00000000000..90c8c311df7 --- /dev/null +++ b/libgfortran/generated/minloc0_16_r16.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_r16 (gfc_array_i16 * retarray, gfc_array_r16 *array); +export_proto(minloc0_16_r16); + +void +minloc0_16_r16 (gfc_array_i16 * retarray, gfc_array_r16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 minval; + + minval = GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_16_r16 (gfc_array_i16 *, gfc_array_r16 *, gfc_array_l4 *); +export_proto(mminloc0_16_r16); + +void +mminloc0_16_r16 (gfc_array_i16 * retarray, gfc_array_r16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 minval; + + minval = GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_16_r4.c b/libgfortran/generated/minloc0_16_r4.c new file mode 100644 index 00000000000..6fba3ddd12b --- /dev/null +++ b/libgfortran/generated/minloc0_16_r4.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_r4 (gfc_array_i16 * retarray, gfc_array_r4 *array); +export_proto(minloc0_16_r4); + +void +minloc0_16_r4 (gfc_array_i16 * retarray, gfc_array_r4 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_4 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_4 minval; + + minval = GFC_REAL_4_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_16_r4 (gfc_array_i16 *, gfc_array_r4 *, gfc_array_l4 *); +export_proto(mminloc0_16_r4); + +void +mminloc0_16_r4 (gfc_array_i16 * retarray, gfc_array_r4 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_REAL_4 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_4 minval; + + minval = GFC_REAL_4_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_16_r8.c b/libgfortran/generated/minloc0_16_r8.c new file mode 100644 index 00000000000..37b9e178e11 --- /dev/null +++ b/libgfortran/generated/minloc0_16_r8.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_r8 (gfc_array_i16 * retarray, gfc_array_r8 *array); +export_proto(minloc0_16_r8); + +void +minloc0_16_r8 (gfc_array_i16 * retarray, gfc_array_r8 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_8 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_8 minval; + + minval = GFC_REAL_8_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_16_r8 (gfc_array_i16 *, gfc_array_r8 *, gfc_array_l4 *); +export_proto(mminloc0_16_r8); + +void +mminloc0_16_r8 (gfc_array_i16 * retarray, gfc_array_r8 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + GFC_REAL_8 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_8 minval; + + minval = GFC_REAL_8_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_4_i16.c b/libgfortran/generated/minloc0_4_i16.c new file mode 100644 index 00000000000..068bbd5137c --- /dev/null +++ b/libgfortran/generated/minloc0_4_i16.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_i16 (gfc_array_i4 * retarray, gfc_array_i16 *array); +export_proto(minloc0_4_i16); + +void +minloc0_4_i16 (gfc_array_i4 * retarray, gfc_array_i16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 minval; + + minval = GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_4_i16 (gfc_array_i4 *, gfc_array_i16 *, gfc_array_l4 *); +export_proto(mminloc0_4_i16); + +void +mminloc0_4_i16 (gfc_array_i4 * retarray, gfc_array_i16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 minval; + + minval = GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_4_i4.c b/libgfortran/generated/minloc0_4_i4.c index 3b82c89a573..e3b15ae895b 100644 --- a/libgfortran/generated/minloc0_4_i4.c +++ b/libgfortran/generated/minloc0_4_i4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + extern void minloc0_4_i4 (gfc_array_i4 * retarray, gfc_array_i4 *array); export_proto(minloc0_4_i4); @@ -286,3 +288,5 @@ mminloc0_4_i4 (gfc_array_i4 * retarray, gfc_array_i4 *array, } } } + +#endif diff --git a/libgfortran/generated/minloc0_4_i8.c b/libgfortran/generated/minloc0_4_i8.c index 98c56499f22..a0214913eb1 100644 --- a/libgfortran/generated/minloc0_4_i8.c +++ b/libgfortran/generated/minloc0_4_i8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) + extern void minloc0_4_i8 (gfc_array_i4 * retarray, gfc_array_i8 *array); export_proto(minloc0_4_i8); @@ -286,3 +288,5 @@ mminloc0_4_i8 (gfc_array_i4 * retarray, gfc_array_i8 *array, } } } + +#endif diff --git a/libgfortran/generated/minloc0_4_r10.c b/libgfortran/generated/minloc0_4_r10.c new file mode 100644 index 00000000000..3f5ddd95d2e --- /dev/null +++ b/libgfortran/generated/minloc0_4_r10.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_r10 (gfc_array_i4 * retarray, gfc_array_r10 *array); +export_proto(minloc0_4_r10); + +void +minloc0_4_r10 (gfc_array_i4 * retarray, gfc_array_r10 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_10 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 minval; + + minval = GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_4_r10 (gfc_array_i4 *, gfc_array_r10 *, gfc_array_l4 *); +export_proto(mminloc0_4_r10); + +void +mminloc0_4_r10 (gfc_array_i4 * retarray, gfc_array_r10 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 minval; + + minval = GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_4_r16.c b/libgfortran/generated/minloc0_4_r16.c new file mode 100644 index 00000000000..82c5f6a01b2 --- /dev/null +++ b/libgfortran/generated/minloc0_4_r16.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_r16 (gfc_array_i4 * retarray, gfc_array_r16 *array); +export_proto(minloc0_4_r16); + +void +minloc0_4_r16 (gfc_array_i4 * retarray, gfc_array_r16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_16 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 minval; + + minval = GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_4_r16 (gfc_array_i4 *, gfc_array_r16 *, gfc_array_l4 *); +export_proto(mminloc0_4_r16); + +void +mminloc0_4_r16 (gfc_array_i4 * retarray, gfc_array_r16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 minval; + + minval = GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_4_r4.c b/libgfortran/generated/minloc0_4_r4.c index c5f9a3796ee..f8cce29a119 100644 --- a/libgfortran/generated/minloc0_4_r4.c +++ b/libgfortran/generated/minloc0_4_r4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) + extern void minloc0_4_r4 (gfc_array_i4 * retarray, gfc_array_r4 *array); export_proto(minloc0_4_r4); @@ -286,3 +288,5 @@ mminloc0_4_r4 (gfc_array_i4 * retarray, gfc_array_r4 *array, } } } + +#endif diff --git a/libgfortran/generated/minloc0_4_r8.c b/libgfortran/generated/minloc0_4_r8.c index d9d51b2beff..dbfa667abad 100644 --- a/libgfortran/generated/minloc0_4_r8.c +++ b/libgfortran/generated/minloc0_4_r8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) + extern void minloc0_4_r8 (gfc_array_i4 * retarray, gfc_array_r8 *array); export_proto(minloc0_4_r8); @@ -286,3 +288,5 @@ mminloc0_4_r8 (gfc_array_i4 * retarray, gfc_array_r8 *array, } } } + +#endif diff --git a/libgfortran/generated/minloc0_8_i16.c b/libgfortran/generated/minloc0_8_i16.c new file mode 100644 index 00000000000..8fabf52e46e --- /dev/null +++ b/libgfortran/generated/minloc0_8_i16.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_i16 (gfc_array_i8 * retarray, gfc_array_i16 *array); +export_proto(minloc0_8_i16); + +void +minloc0_8_i16 (gfc_array_i8 * retarray, gfc_array_i16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 minval; + + minval = GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_8_i16 (gfc_array_i8 *, gfc_array_i16 *, gfc_array_l4 *); +export_proto(mminloc0_8_i16); + +void +mminloc0_8_i16 (gfc_array_i8 * retarray, gfc_array_i16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_INTEGER_16 minval; + + minval = GFC_INTEGER_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_8_i4.c b/libgfortran/generated/minloc0_8_i4.c index 9d7abfa4fd9..49fe0f4b36e 100644 --- a/libgfortran/generated/minloc0_8_i4.c +++ b/libgfortran/generated/minloc0_8_i4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) + extern void minloc0_8_i4 (gfc_array_i8 * retarray, gfc_array_i4 *array); export_proto(minloc0_8_i4); @@ -286,3 +288,5 @@ mminloc0_8_i4 (gfc_array_i8 * retarray, gfc_array_i4 *array, } } } + +#endif diff --git a/libgfortran/generated/minloc0_8_i8.c b/libgfortran/generated/minloc0_8_i8.c index bfeda262527..d4327f05546 100644 --- a/libgfortran/generated/minloc0_8_i8.c +++ b/libgfortran/generated/minloc0_8_i8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + extern void minloc0_8_i8 (gfc_array_i8 * retarray, gfc_array_i8 *array); export_proto(minloc0_8_i8); @@ -286,3 +288,5 @@ mminloc0_8_i8 (gfc_array_i8 * retarray, gfc_array_i8 *array, } } } + +#endif diff --git a/libgfortran/generated/minloc0_8_r10.c b/libgfortran/generated/minloc0_8_r10.c new file mode 100644 index 00000000000..2cd231b387a --- /dev/null +++ b/libgfortran/generated/minloc0_8_r10.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_r10 (gfc_array_i8 * retarray, gfc_array_r10 *array); +export_proto(minloc0_8_r10); + +void +minloc0_8_r10 (gfc_array_i8 * retarray, gfc_array_r10 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_10 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 minval; + + minval = GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_8_r10 (gfc_array_i8 *, gfc_array_r10 *, gfc_array_l4 *); +export_proto(mminloc0_8_r10); + +void +mminloc0_8_r10 (gfc_array_i8 * retarray, gfc_array_r10 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_10 minval; + + minval = GFC_REAL_10_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_8_r16.c b/libgfortran/generated/minloc0_8_r16.c new file mode 100644 index 00000000000..ff5925bd8eb --- /dev/null +++ b/libgfortran/generated/minloc0_8_r16.c @@ -0,0 +1,292 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_r16 (gfc_array_i8 * retarray, gfc_array_r16 *array); +export_proto(minloc0_8_r16); + +void +minloc0_8_r16 (gfc_array_i8 * retarray, gfc_array_r16 *array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_REAL_16 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 minval; + + minval = GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + } +} + + +extern void mminloc0_8_r16 (gfc_array_i8 *, gfc_array_r16 *, gfc_array_l4 *); +export_proto(mminloc0_8_r16); + +void +mminloc0_8_r16 (gfc_array_i8 * retarray, gfc_array_r16 *array, + gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = rank-1; + retarray->dim[0].stride = 1; + retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + retarray->offset = 0; + retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + else + { + if (GFC_DESCRIPTOR_RANK (retarray) != 1) + runtime_error ("rank of return array does not equal 1"); + + if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) + runtime_error ("dimension of return array incorrect"); + + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + } + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + dstride = retarray->dim[0].stride; + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_REAL_16 minval; + + minval = GFC_REAL_16_HUGE; + + while (base) + { + { + /* Implementation start. */ + + if (*mbase && *base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_8_r4.c b/libgfortran/generated/minloc0_8_r4.c index 1b1d57bc9f0..a522c755162 100644 --- a/libgfortran/generated/minloc0_8_r4.c +++ b/libgfortran/generated/minloc0_8_r4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) + extern void minloc0_8_r4 (gfc_array_i8 * retarray, gfc_array_r4 *array); export_proto(minloc0_8_r4); @@ -286,3 +288,5 @@ mminloc0_8_r4 (gfc_array_i8 * retarray, gfc_array_r4 *array, } } } + +#endif diff --git a/libgfortran/generated/minloc0_8_r8.c b/libgfortran/generated/minloc0_8_r8.c index c7a276979db..ba3cfe625ee 100644 --- a/libgfortran/generated/minloc0_8_r8.c +++ b/libgfortran/generated/minloc0_8_r8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) + extern void minloc0_8_r8 (gfc_array_i8 * retarray, gfc_array_r8 *array); export_proto(minloc0_8_r8); @@ -286,3 +288,5 @@ mminloc0_8_r8 (gfc_array_i8 * retarray, gfc_array_r8 *array, } } } + +#endif diff --git a/libgfortran/generated/minloc1_16_i16.c b/libgfortran/generated/minloc1_16_i16.c new file mode 100644 index 00000000000..906030c9b6d --- /dev/null +++ b/libgfortran/generated/minloc1_16_i16.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *); +export_proto(minloc1_16_i16); + +void +minloc1_16_i16 (gfc_array_i16 *retarray, gfc_array_i16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_16 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_16 minval; + minval = GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_16_i16); + +void +mminloc1_16_i16 (gfc_array_i16 * retarray, gfc_array_i16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 minval; + minval = GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_i4.c b/libgfortran/generated/minloc1_16_i4.c new file mode 100644 index 00000000000..b7fe1a0843f --- /dev/null +++ b/libgfortran/generated/minloc1_16_i4.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_i4 (gfc_array_i16 *, gfc_array_i4 *, index_type *); +export_proto(minloc1_16_i4); + +void +minloc1_16_i4 (gfc_array_i16 *retarray, gfc_array_i4 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_4 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_4 minval; + minval = GFC_INTEGER_4_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_i4 (gfc_array_i16 *, gfc_array_i4 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_16_i4); + +void +mminloc1_16_i4 (gfc_array_i16 * retarray, gfc_array_i4 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_INTEGER_4 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_4 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_4 minval; + minval = GFC_INTEGER_4_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_i8.c b/libgfortran/generated/minloc1_16_i8.c new file mode 100644 index 00000000000..20c17f2a9cb --- /dev/null +++ b/libgfortran/generated/minloc1_16_i8.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_i8 (gfc_array_i16 *, gfc_array_i8 *, index_type *); +export_proto(minloc1_16_i8); + +void +minloc1_16_i8 (gfc_array_i16 *retarray, gfc_array_i8 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_8 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_8 minval; + minval = GFC_INTEGER_8_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_i8 (gfc_array_i16 *, gfc_array_i8 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_16_i8); + +void +mminloc1_16_i8 (gfc_array_i16 * retarray, gfc_array_i8 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_INTEGER_8 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_8 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_8 minval; + minval = GFC_INTEGER_8_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_r10.c b/libgfortran/generated/minloc1_16_r10.c new file mode 100644 index 00000000000..48519c2697e --- /dev/null +++ b/libgfortran/generated/minloc1_16_r10.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_r10 (gfc_array_i16 *, gfc_array_r10 *, index_type *); +export_proto(minloc1_16_r10); + +void +minloc1_16_r10 (gfc_array_i16 *retarray, gfc_array_r10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_10 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_10 minval; + minval = GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_r10 (gfc_array_i16 *, gfc_array_r10 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_16_r10); + +void +mminloc1_16_r10 (gfc_array_i16 * retarray, gfc_array_r10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 minval; + minval = GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_r16.c b/libgfortran/generated/minloc1_16_r16.c new file mode 100644 index 00000000000..41fed8a3067 --- /dev/null +++ b/libgfortran/generated/minloc1_16_r16.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_r16 (gfc_array_i16 *, gfc_array_r16 *, index_type *); +export_proto(minloc1_16_r16); + +void +minloc1_16_r16 (gfc_array_i16 *retarray, gfc_array_r16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_16 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_16 minval; + minval = GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_r16 (gfc_array_i16 *, gfc_array_r16 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_16_r16); + +void +mminloc1_16_r16 (gfc_array_i16 * retarray, gfc_array_r16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 minval; + minval = GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_r4.c b/libgfortran/generated/minloc1_16_r4.c new file mode 100644 index 00000000000..b3a4017a9f7 --- /dev/null +++ b/libgfortran/generated/minloc1_16_r4.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_r4 (gfc_array_i16 *, gfc_array_r4 *, index_type *); +export_proto(minloc1_16_r4); + +void +minloc1_16_r4 (gfc_array_i16 *retarray, gfc_array_r4 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_4 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_4 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_4 minval; + minval = GFC_REAL_4_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_r4 (gfc_array_i16 *, gfc_array_r4 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_16_r4); + +void +mminloc1_16_r4 (gfc_array_i16 * retarray, gfc_array_r4 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_REAL_4 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_4 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_4 minval; + minval = GFC_REAL_4_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_r8.c b/libgfortran/generated/minloc1_16_r8.c new file mode 100644 index 00000000000..a9a0267aa5a --- /dev/null +++ b/libgfortran/generated/minloc1_16_r8.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_r8 (gfc_array_i16 *, gfc_array_r8 *, index_type *); +export_proto(minloc1_16_r8); + +void +minloc1_16_r8 (gfc_array_i16 *retarray, gfc_array_r8 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_8 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_8 *src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_8 minval; + minval = GFC_REAL_8_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_r8 (gfc_array_i16 *, gfc_array_r8 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_16_r8); + +void +mminloc1_16_r8 (gfc_array_i16 * retarray, gfc_array_r8 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_REAL_8 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_8 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_8 minval; + minval = GFC_REAL_8_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_i16.c b/libgfortran/generated/minloc1_4_i16.c new file mode 100644 index 00000000000..3446a1a585c --- /dev/null +++ b/libgfortran/generated/minloc1_4_i16.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_i16 (gfc_array_i4 *, gfc_array_i16 *, index_type *); +export_proto(minloc1_4_i16); + +void +minloc1_4_i16 (gfc_array_i4 *retarray, gfc_array_i16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_16 *src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_16 minval; + minval = GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_i16 (gfc_array_i4 *, gfc_array_i16 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_4_i16); + +void +mminloc1_4_i16 (gfc_array_i4 * retarray, gfc_array_i16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 minval; + minval = GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_i4.c b/libgfortran/generated/minloc1_4_i4.c index 2aa1d4d057b..f7207192b1c 100644 --- a/libgfortran/generated/minloc1_4_i4.c +++ b/libgfortran/generated/minloc1_4_i4.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + extern void minloc1_4_i4 (gfc_array_i4 *, gfc_array_i4 *, index_type *); export_proto(minloc1_4_i4); @@ -341,3 +344,4 @@ mminloc1_4_i4 (gfc_array_i4 * retarray, gfc_array_i4 * array, } } +#endif diff --git a/libgfortran/generated/minloc1_4_i8.c b/libgfortran/generated/minloc1_4_i8.c index 08a74c7e60f..b049b19d755 100644 --- a/libgfortran/generated/minloc1_4_i8.c +++ b/libgfortran/generated/minloc1_4_i8.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) + + extern void minloc1_4_i8 (gfc_array_i4 *, gfc_array_i8 *, index_type *); export_proto(minloc1_4_i8); @@ -341,3 +344,4 @@ mminloc1_4_i8 (gfc_array_i4 * retarray, gfc_array_i8 * array, } } +#endif diff --git a/libgfortran/generated/minloc1_4_r10.c b/libgfortran/generated/minloc1_4_r10.c new file mode 100644 index 00000000000..983db754f5f --- /dev/null +++ b/libgfortran/generated/minloc1_4_r10.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_r10 (gfc_array_i4 *, gfc_array_r10 *, index_type *); +export_proto(minloc1_4_r10); + +void +minloc1_4_r10 (gfc_array_i4 *retarray, gfc_array_r10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_10 *src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_10 minval; + minval = GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_r10 (gfc_array_i4 *, gfc_array_r10 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_4_r10); + +void +mminloc1_4_r10 (gfc_array_i4 * retarray, gfc_array_r10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 minval; + minval = GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_r16.c b/libgfortran/generated/minloc1_4_r16.c new file mode 100644 index 00000000000..68f142125c9 --- /dev/null +++ b/libgfortran/generated/minloc1_4_r16.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_r16 (gfc_array_i4 *, gfc_array_r16 *, index_type *); +export_proto(minloc1_4_r16); + +void +minloc1_4_r16 (gfc_array_i4 *retarray, gfc_array_r16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *base; + GFC_INTEGER_4 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_16 *src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_16 minval; + minval = GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_r16 (gfc_array_i4 *, gfc_array_r16 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_4_r16); + +void +mminloc1_4_r16 (gfc_array_i4 * retarray, gfc_array_r16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 minval; + minval = GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_r4.c b/libgfortran/generated/minloc1_4_r4.c index 9d0af3bc4be..e7191fd4de4 100644 --- a/libgfortran/generated/minloc1_4_r4.c +++ b/libgfortran/generated/minloc1_4_r4.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) + + extern void minloc1_4_r4 (gfc_array_i4 *, gfc_array_r4 *, index_type *); export_proto(minloc1_4_r4); @@ -341,3 +344,4 @@ mminloc1_4_r4 (gfc_array_i4 * retarray, gfc_array_r4 * array, } } +#endif diff --git a/libgfortran/generated/minloc1_4_r8.c b/libgfortran/generated/minloc1_4_r8.c index de5440b6165..9d4c981cdc7 100644 --- a/libgfortran/generated/minloc1_4_r8.c +++ b/libgfortran/generated/minloc1_4_r8.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) + + extern void minloc1_4_r8 (gfc_array_i4 *, gfc_array_r8 *, index_type *); export_proto(minloc1_4_r8); @@ -341,3 +344,4 @@ mminloc1_4_r8 (gfc_array_i4 * retarray, gfc_array_r8 * array, } } +#endif diff --git a/libgfortran/generated/minloc1_8_i16.c b/libgfortran/generated/minloc1_8_i16.c new file mode 100644 index 00000000000..13c2cb74a42 --- /dev/null +++ b/libgfortran/generated/minloc1_8_i16.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_i16 (gfc_array_i8 *, gfc_array_i16 *, index_type *); +export_proto(minloc1_8_i16); + +void +minloc1_8_i16 (gfc_array_i8 *retarray, gfc_array_i16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_16 *src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_16 minval; + minval = GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_i16 (gfc_array_i8 *, gfc_array_i16 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_8_i16); + +void +mminloc1_8_i16 (gfc_array_i8 * retarray, gfc_array_i16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 minval; + minval = GFC_INTEGER_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_i4.c b/libgfortran/generated/minloc1_8_i4.c index 66699886d74..f682c10936c 100644 --- a/libgfortran/generated/minloc1_8_i4.c +++ b/libgfortran/generated/minloc1_8_i4.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) + + extern void minloc1_8_i4 (gfc_array_i8 *, gfc_array_i4 *, index_type *); export_proto(minloc1_8_i4); @@ -341,3 +344,4 @@ mminloc1_8_i4 (gfc_array_i8 * retarray, gfc_array_i4 * array, } } +#endif diff --git a/libgfortran/generated/minloc1_8_i8.c b/libgfortran/generated/minloc1_8_i8.c index 4adb1492d98..9a2a5231b5a 100644 --- a/libgfortran/generated/minloc1_8_i8.c +++ b/libgfortran/generated/minloc1_8_i8.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + extern void minloc1_8_i8 (gfc_array_i8 *, gfc_array_i8 *, index_type *); export_proto(minloc1_8_i8); @@ -341,3 +344,4 @@ mminloc1_8_i8 (gfc_array_i8 * retarray, gfc_array_i8 * array, } } +#endif diff --git a/libgfortran/generated/minloc1_8_r10.c b/libgfortran/generated/minloc1_8_r10.c new file mode 100644 index 00000000000..2058453584a --- /dev/null +++ b/libgfortran/generated/minloc1_8_r10.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_r10 (gfc_array_i8 *, gfc_array_r10 *, index_type *); +export_proto(minloc1_8_r10); + +void +minloc1_8_r10 (gfc_array_i8 *retarray, gfc_array_r10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_10 *src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_10 minval; + minval = GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_r10 (gfc_array_i8 *, gfc_array_r10 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_8_r10); + +void +mminloc1_8_r10 (gfc_array_i8 * retarray, gfc_array_r10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 minval; + minval = GFC_REAL_10_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_r16.c b/libgfortran/generated/minloc1_8_r16.c new file mode 100644 index 00000000000..e417f620ba6 --- /dev/null +++ b/libgfortran/generated/minloc1_8_r16.c @@ -0,0 +1,347 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include <limits.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_r16 (gfc_array_i8 *, gfc_array_r16 *, index_type *); +export_proto(minloc1_8_r16); + +void +minloc1_8_r16 (gfc_array_i8 *retarray, gfc_array_r16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *base; + GFC_INTEGER_8 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_16 *src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_16 minval; + minval = GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_r16 (gfc_array_i8 *, gfc_array_r16 *, index_type *, + gfc_array_l4 *); +export_proto(mminloc1_8_r16); + +void +mminloc1_8_r16 (gfc_array_i8 * retarray, gfc_array_r16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 minval; + minval = GFC_REAL_16_HUGE; + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_r4.c b/libgfortran/generated/minloc1_8_r4.c index 45cb8343eef..8f154dce275 100644 --- a/libgfortran/generated/minloc1_8_r4.c +++ b/libgfortran/generated/minloc1_8_r4.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) + + extern void minloc1_8_r4 (gfc_array_i8 *, gfc_array_r4 *, index_type *); export_proto(minloc1_8_r4); @@ -341,3 +344,4 @@ mminloc1_8_r4 (gfc_array_i8 * retarray, gfc_array_r4 * array, } } +#endif diff --git a/libgfortran/generated/minloc1_8_r8.c b/libgfortran/generated/minloc1_8_r8.c index f6c72e49837..20a757a9217 100644 --- a/libgfortran/generated/minloc1_8_r8.c +++ b/libgfortran/generated/minloc1_8_r8.c @@ -36,6 +36,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) + + extern void minloc1_8_r8 (gfc_array_i8 *, gfc_array_r8 *, index_type *); export_proto(minloc1_8_r8); @@ -341,3 +344,4 @@ mminloc1_8_r8 (gfc_array_i8 * retarray, gfc_array_r8 * array, } } +#endif diff --git a/libgfortran/generated/minval_i16.c b/libgfortran/generated/minval_i16.c new file mode 100644 index 00000000000..34963ae9725 --- /dev/null +++ b/libgfortran/generated/minval_i16.c @@ -0,0 +1,336 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void minval_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *); +export_proto(minval_i16); + +void +minval_i16 (gfc_array_i16 *retarray, gfc_array_i16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_16 *src; + GFC_INTEGER_16 result; + src = base; + { + + result = GFC_INTEGER_16_HUGE; + if (len <= 0) + *dest = GFC_INTEGER_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *, + gfc_array_l4 *); +export_proto(mminval_i16); + +void +mminval_i16 (gfc_array_i16 * retarray, gfc_array_i16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + result = GFC_INTEGER_16_HUGE; + if (len <= 0) + *dest = GFC_INTEGER_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_i4.c b/libgfortran/generated/minval_i4.c index 01ef0236efb..826d2e902e2 100644 --- a/libgfortran/generated/minval_i4.c +++ b/libgfortran/generated/minval_i4.c @@ -35,6 +35,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + extern void minval_i4 (gfc_array_i4 *, gfc_array_i4 *, index_type *); export_proto(minval_i4); @@ -330,3 +333,4 @@ mminval_i4 (gfc_array_i4 * retarray, gfc_array_i4 * array, } } +#endif diff --git a/libgfortran/generated/minval_i8.c b/libgfortran/generated/minval_i8.c index 1d769030625..e58a97ba90d 100644 --- a/libgfortran/generated/minval_i8.c +++ b/libgfortran/generated/minval_i8.c @@ -35,6 +35,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + extern void minval_i8 (gfc_array_i8 *, gfc_array_i8 *, index_type *); export_proto(minval_i8); @@ -330,3 +333,4 @@ mminval_i8 (gfc_array_i8 * retarray, gfc_array_i8 * array, } } +#endif diff --git a/libgfortran/generated/minval_r10.c b/libgfortran/generated/minval_r10.c new file mode 100644 index 00000000000..ec494fba168 --- /dev/null +++ b/libgfortran/generated/minval_r10.c @@ -0,0 +1,336 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) + + +extern void minval_r10 (gfc_array_r10 *, gfc_array_r10 *, index_type *); +export_proto(minval_r10); + +void +minval_r10 (gfc_array_r10 *retarray, gfc_array_r10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *base; + GFC_REAL_10 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_10 *src; + GFC_REAL_10 result; + src = base; + { + + result = GFC_REAL_10_HUGE; + if (len <= 0) + *dest = GFC_REAL_10_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_r10 (gfc_array_r10 *, gfc_array_r10 *, index_type *, + gfc_array_l4 *); +export_proto(mminval_r10); + +void +mminval_r10 (gfc_array_r10 * retarray, gfc_array_r10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_REAL_10 result; + src = base; + msrc = mbase; + { + + result = GFC_REAL_10_HUGE; + if (len <= 0) + *dest = GFC_REAL_10_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_r16.c b/libgfortran/generated/minval_r16.c new file mode 100644 index 00000000000..d71b00756de --- /dev/null +++ b/libgfortran/generated/minval_r16.c @@ -0,0 +1,336 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <float.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) + + +extern void minval_r16 (gfc_array_r16 *, gfc_array_r16 *, index_type *); +export_proto(minval_r16); + +void +minval_r16 (gfc_array_r16 *retarray, gfc_array_r16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *base; + GFC_REAL_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_16 *src; + GFC_REAL_16 result; + src = base; + { + + result = GFC_REAL_16_HUGE; + if (len <= 0) + *dest = GFC_REAL_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src < result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_r16 (gfc_array_r16 *, gfc_array_r16 *, index_type *, + gfc_array_l4 *); +export_proto(mminval_r16); + +void +mminval_r16 (gfc_array_r16 * retarray, gfc_array_r16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_REAL_16 result; + src = base; + msrc = mbase; + { + + result = GFC_REAL_16_HUGE; + if (len <= 0) + *dest = GFC_REAL_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc && *src < result) + result = *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_r4.c b/libgfortran/generated/minval_r4.c index c4e30392166..8228f991fcb 100644 --- a/libgfortran/generated/minval_r4.c +++ b/libgfortran/generated/minval_r4.c @@ -35,6 +35,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) + + extern void minval_r4 (gfc_array_r4 *, gfc_array_r4 *, index_type *); export_proto(minval_r4); @@ -330,3 +333,4 @@ mminval_r4 (gfc_array_r4 * retarray, gfc_array_r4 * array, } } +#endif diff --git a/libgfortran/generated/minval_r8.c b/libgfortran/generated/minval_r8.c index de6eea1cd53..81a8b2127e8 100644 --- a/libgfortran/generated/minval_r8.c +++ b/libgfortran/generated/minval_r8.c @@ -35,6 +35,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) + + extern void minval_r8 (gfc_array_r8 *, gfc_array_r8 *, index_type *); export_proto(minval_r8); @@ -330,3 +333,4 @@ mminval_r8 (gfc_array_r8 * retarray, gfc_array_r8 * array, } } +#endif diff --git a/libgfortran/generated/nearest_r10.c b/libgfortran/generated/nearest_r10.c new file mode 100644 index 00000000000..5a02d74a2ed --- /dev/null +++ b/libgfortran/generated/nearest_r10.c @@ -0,0 +1,56 @@ +/* Implementation of the NEAREST intrinsic + Copyright 2003 Free Software Foundation, Inc. + Contributed by Richard Henderson <rth@redhat.com>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <math.h> +#include <float.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_COPYSIGNL) && defined (HAVE_NEXTAFTERL) + +extern GFC_REAL_10 nearest_r10 (GFC_REAL_10 s, GFC_REAL_10 dir); +export_proto(nearest_r10); + +GFC_REAL_10 +nearest_r10 (GFC_REAL_10 s, GFC_REAL_10 dir) +{ + dir = copysignl (__builtin_infl (), dir); + if (FLT_EVAL_METHOD != 0) + { + /* ??? Work around glibc bug on x86. */ + volatile GFC_REAL_10 r = nextafterl (s, dir); + return r; + } + else + return nextafterl (s, dir); +} + +#endif diff --git a/libgfortran/generated/nearest_r16.c b/libgfortran/generated/nearest_r16.c new file mode 100644 index 00000000000..eeb532a5230 --- /dev/null +++ b/libgfortran/generated/nearest_r16.c @@ -0,0 +1,56 @@ +/* Implementation of the NEAREST intrinsic + Copyright 2003 Free Software Foundation, Inc. + Contributed by Richard Henderson <rth@redhat.com>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <math.h> +#include <float.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_COPYSIGNL) && defined (HAVE_NEXTAFTERL) + +extern GFC_REAL_16 nearest_r16 (GFC_REAL_16 s, GFC_REAL_16 dir); +export_proto(nearest_r16); + +GFC_REAL_16 +nearest_r16 (GFC_REAL_16 s, GFC_REAL_16 dir) +{ + dir = copysignl (__builtin_infl (), dir); + if (FLT_EVAL_METHOD != 0) + { + /* ??? Work around glibc bug on x86. */ + volatile GFC_REAL_16 r = nextafterl (s, dir); + return r; + } + else + return nextafterl (s, dir); +} + +#endif diff --git a/libgfortran/generated/nearest_r4.c b/libgfortran/generated/nearest_r4.c index 265b6493c78..02fd6aa5cb7 100644 --- a/libgfortran/generated/nearest_r4.c +++ b/libgfortran/generated/nearest_r4.c @@ -27,11 +27,15 @@ You should have received a copy of the GNU General Public License along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include "config.h" #include <math.h> #include <float.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_COPYSIGNF) && defined (HAVE_NEXTAFTERF) + extern GFC_REAL_4 nearest_r4 (GFC_REAL_4 s, GFC_REAL_4 dir); export_proto(nearest_r4); @@ -48,3 +52,5 @@ nearest_r4 (GFC_REAL_4 s, GFC_REAL_4 dir) else return nextafterf (s, dir); } + +#endif diff --git a/libgfortran/generated/nearest_r8.c b/libgfortran/generated/nearest_r8.c index 337cce6cae5..e050f74077f 100644 --- a/libgfortran/generated/nearest_r8.c +++ b/libgfortran/generated/nearest_r8.c @@ -27,11 +27,15 @@ You should have received a copy of the GNU General Public License along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include "config.h" #include <math.h> #include <float.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_COPYSIGN) && defined (HAVE_NEXTAFTER) + extern GFC_REAL_8 nearest_r8 (GFC_REAL_8 s, GFC_REAL_8 dir); export_proto(nearest_r8); @@ -48,3 +52,5 @@ nearest_r8 (GFC_REAL_8 s, GFC_REAL_8 dir) else return nextafter (s, dir); } + +#endif diff --git a/libgfortran/generated/pow_c10_i16.c b/libgfortran/generated/pow_c10_i16.c new file mode 100644 index 00000000000..6332013bdbc --- /dev/null +++ b/libgfortran/generated/pow_c10_i16.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_COMPLEX_10) && defined (HAVE_GFC_INTEGER_16) + +GFC_COMPLEX_10 pow_c10_i16 (GFC_COMPLEX_10 a, GFC_INTEGER_16 b); +export_proto(pow_c10_i16); + +GFC_COMPLEX_10 +pow_c10_i16 (GFC_COMPLEX_10 a, GFC_INTEGER_16 b) +{ + GFC_COMPLEX_10 pow, x; + GFC_INTEGER_16 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_c10_i4.c b/libgfortran/generated/pow_c10_i4.c new file mode 100644 index 00000000000..ccb1a0c6a2b --- /dev/null +++ b/libgfortran/generated/pow_c10_i4.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_COMPLEX_10) && defined (HAVE_GFC_INTEGER_4) + +GFC_COMPLEX_10 pow_c10_i4 (GFC_COMPLEX_10 a, GFC_INTEGER_4 b); +export_proto(pow_c10_i4); + +GFC_COMPLEX_10 +pow_c10_i4 (GFC_COMPLEX_10 a, GFC_INTEGER_4 b) +{ + GFC_COMPLEX_10 pow, x; + GFC_INTEGER_4 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_c10_i8.c b/libgfortran/generated/pow_c10_i8.c new file mode 100644 index 00000000000..0f2b2426481 --- /dev/null +++ b/libgfortran/generated/pow_c10_i8.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_COMPLEX_10) && defined (HAVE_GFC_INTEGER_8) + +GFC_COMPLEX_10 pow_c10_i8 (GFC_COMPLEX_10 a, GFC_INTEGER_8 b); +export_proto(pow_c10_i8); + +GFC_COMPLEX_10 +pow_c10_i8 (GFC_COMPLEX_10 a, GFC_INTEGER_8 b) +{ + GFC_COMPLEX_10 pow, x; + GFC_INTEGER_8 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_c16_i16.c b/libgfortran/generated/pow_c16_i16.c new file mode 100644 index 00000000000..a6d888369b2 --- /dev/null +++ b/libgfortran/generated/pow_c16_i16.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_COMPLEX_16) && defined (HAVE_GFC_INTEGER_16) + +GFC_COMPLEX_16 pow_c16_i16 (GFC_COMPLEX_16 a, GFC_INTEGER_16 b); +export_proto(pow_c16_i16); + +GFC_COMPLEX_16 +pow_c16_i16 (GFC_COMPLEX_16 a, GFC_INTEGER_16 b) +{ + GFC_COMPLEX_16 pow, x; + GFC_INTEGER_16 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_c16_i4.c b/libgfortran/generated/pow_c16_i4.c new file mode 100644 index 00000000000..d3960520cf9 --- /dev/null +++ b/libgfortran/generated/pow_c16_i4.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_COMPLEX_16) && defined (HAVE_GFC_INTEGER_4) + +GFC_COMPLEX_16 pow_c16_i4 (GFC_COMPLEX_16 a, GFC_INTEGER_4 b); +export_proto(pow_c16_i4); + +GFC_COMPLEX_16 +pow_c16_i4 (GFC_COMPLEX_16 a, GFC_INTEGER_4 b) +{ + GFC_COMPLEX_16 pow, x; + GFC_INTEGER_4 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_c16_i8.c b/libgfortran/generated/pow_c16_i8.c new file mode 100644 index 00000000000..0a0e94d0613 --- /dev/null +++ b/libgfortran/generated/pow_c16_i8.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_COMPLEX_16) && defined (HAVE_GFC_INTEGER_8) + +GFC_COMPLEX_16 pow_c16_i8 (GFC_COMPLEX_16 a, GFC_INTEGER_8 b); +export_proto(pow_c16_i8); + +GFC_COMPLEX_16 +pow_c16_i8 (GFC_COMPLEX_16 a, GFC_INTEGER_8 b) +{ + GFC_COMPLEX_16 pow, x; + GFC_INTEGER_8 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_c4_i16.c b/libgfortran/generated/pow_c4_i16.c new file mode 100644 index 00000000000..1085ad21caf --- /dev/null +++ b/libgfortran/generated/pow_c4_i16.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_COMPLEX_4) && defined (HAVE_GFC_INTEGER_16) + +GFC_COMPLEX_4 pow_c4_i16 (GFC_COMPLEX_4 a, GFC_INTEGER_16 b); +export_proto(pow_c4_i16); + +GFC_COMPLEX_4 +pow_c4_i16 (GFC_COMPLEX_4 a, GFC_INTEGER_16 b) +{ + GFC_COMPLEX_4 pow, x; + GFC_INTEGER_16 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_c4_i4.c b/libgfortran/generated/pow_c4_i4.c index a25607e570b..ca376710fba 100644 --- a/libgfortran/generated/pow_c4_i4.c +++ b/libgfortran/generated/pow_c4_i4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_COMPLEX_4) && defined (HAVE_GFC_INTEGER_4) + GFC_COMPLEX_4 pow_c4_i4 (GFC_COMPLEX_4 a, GFC_INTEGER_4 b); export_proto(pow_c4_i4); @@ -70,3 +72,5 @@ pow_c4_i4 (GFC_COMPLEX_4 a, GFC_INTEGER_4 b) } return pow; } + +#endif diff --git a/libgfortran/generated/pow_c4_i8.c b/libgfortran/generated/pow_c4_i8.c index a6098365d29..f9fc849ca19 100644 --- a/libgfortran/generated/pow_c4_i8.c +++ b/libgfortran/generated/pow_c4_i8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_COMPLEX_4) && defined (HAVE_GFC_INTEGER_8) + GFC_COMPLEX_4 pow_c4_i8 (GFC_COMPLEX_4 a, GFC_INTEGER_8 b); export_proto(pow_c4_i8); @@ -70,3 +72,5 @@ pow_c4_i8 (GFC_COMPLEX_4 a, GFC_INTEGER_8 b) } return pow; } + +#endif diff --git a/libgfortran/generated/pow_c8_i16.c b/libgfortran/generated/pow_c8_i16.c new file mode 100644 index 00000000000..0fc162b5014 --- /dev/null +++ b/libgfortran/generated/pow_c8_i16.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_COMPLEX_8) && defined (HAVE_GFC_INTEGER_16) + +GFC_COMPLEX_8 pow_c8_i16 (GFC_COMPLEX_8 a, GFC_INTEGER_16 b); +export_proto(pow_c8_i16); + +GFC_COMPLEX_8 +pow_c8_i16 (GFC_COMPLEX_8 a, GFC_INTEGER_16 b) +{ + GFC_COMPLEX_8 pow, x; + GFC_INTEGER_16 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_c8_i4.c b/libgfortran/generated/pow_c8_i4.c index e205998b57e..64b4b3c5b69 100644 --- a/libgfortran/generated/pow_c8_i4.c +++ b/libgfortran/generated/pow_c8_i4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_COMPLEX_8) && defined (HAVE_GFC_INTEGER_4) + GFC_COMPLEX_8 pow_c8_i4 (GFC_COMPLEX_8 a, GFC_INTEGER_4 b); export_proto(pow_c8_i4); @@ -70,3 +72,5 @@ pow_c8_i4 (GFC_COMPLEX_8 a, GFC_INTEGER_4 b) } return pow; } + +#endif diff --git a/libgfortran/generated/pow_c8_i8.c b/libgfortran/generated/pow_c8_i8.c index 922fbffdb29..39a5d6b71e0 100644 --- a/libgfortran/generated/pow_c8_i8.c +++ b/libgfortran/generated/pow_c8_i8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_COMPLEX_8) && defined (HAVE_GFC_INTEGER_8) + GFC_COMPLEX_8 pow_c8_i8 (GFC_COMPLEX_8 a, GFC_INTEGER_8 b); export_proto(pow_c8_i8); @@ -70,3 +72,5 @@ pow_c8_i8 (GFC_COMPLEX_8 a, GFC_INTEGER_8 b) } return pow; } + +#endif diff --git a/libgfortran/generated/pow_i16_i16.c b/libgfortran/generated/pow_i16_i16.c new file mode 100644 index 00000000000..eda2fb6dc7c --- /dev/null +++ b/libgfortran/generated/pow_i16_i16.c @@ -0,0 +1,78 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + +GFC_INTEGER_16 pow_i16_i16 (GFC_INTEGER_16 a, GFC_INTEGER_16 b); +export_proto(pow_i16_i16); + +GFC_INTEGER_16 +pow_i16_i16 (GFC_INTEGER_16 a, GFC_INTEGER_16 b) +{ + GFC_INTEGER_16 pow, x; + GFC_INTEGER_16 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + if (x == 1) + return 1; + if (x == -1) + return (n & 1) ? -1 : 1; + return (x == 0) ? 1 / x : 0; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_i16_i4.c b/libgfortran/generated/pow_i16_i4.c new file mode 100644 index 00000000000..6e4d65c35c4 --- /dev/null +++ b/libgfortran/generated/pow_i16_i4.c @@ -0,0 +1,78 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) + +GFC_INTEGER_16 pow_i16_i4 (GFC_INTEGER_16 a, GFC_INTEGER_4 b); +export_proto(pow_i16_i4); + +GFC_INTEGER_16 +pow_i16_i4 (GFC_INTEGER_16 a, GFC_INTEGER_4 b) +{ + GFC_INTEGER_16 pow, x; + GFC_INTEGER_4 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + if (x == 1) + return 1; + if (x == -1) + return (n & 1) ? -1 : 1; + return (x == 0) ? 1 / x : 0; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_i16_i8.c b/libgfortran/generated/pow_i16_i8.c new file mode 100644 index 00000000000..d1849511a29 --- /dev/null +++ b/libgfortran/generated/pow_i16_i8.c @@ -0,0 +1,78 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) + +GFC_INTEGER_16 pow_i16_i8 (GFC_INTEGER_16 a, GFC_INTEGER_8 b); +export_proto(pow_i16_i8); + +GFC_INTEGER_16 +pow_i16_i8 (GFC_INTEGER_16 a, GFC_INTEGER_8 b) +{ + GFC_INTEGER_16 pow, x; + GFC_INTEGER_8 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + if (x == 1) + return 1; + if (x == -1) + return (n & 1) ? -1 : 1; + return (x == 0) ? 1 / x : 0; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_i4_i16.c b/libgfortran/generated/pow_i4_i16.c new file mode 100644 index 00000000000..f515f80359e --- /dev/null +++ b/libgfortran/generated/pow_i4_i16.c @@ -0,0 +1,78 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) + +GFC_INTEGER_4 pow_i4_i16 (GFC_INTEGER_4 a, GFC_INTEGER_16 b); +export_proto(pow_i4_i16); + +GFC_INTEGER_4 +pow_i4_i16 (GFC_INTEGER_4 a, GFC_INTEGER_16 b) +{ + GFC_INTEGER_4 pow, x; + GFC_INTEGER_16 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + if (x == 1) + return 1; + if (x == -1) + return (n & 1) ? -1 : 1; + return (x == 0) ? 1 / x : 0; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_i4_i4.c b/libgfortran/generated/pow_i4_i4.c index 86b49f7f3e0..184fe6d986e 100644 --- a/libgfortran/generated/pow_i4_i4.c +++ b/libgfortran/generated/pow_i4_i4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + GFC_INTEGER_4 pow_i4_i4 (GFC_INTEGER_4 a, GFC_INTEGER_4 b); export_proto(pow_i4_i4); @@ -72,3 +74,5 @@ pow_i4_i4 (GFC_INTEGER_4 a, GFC_INTEGER_4 b) } return pow; } + +#endif diff --git a/libgfortran/generated/pow_i4_i8.c b/libgfortran/generated/pow_i4_i8.c index 5353f78a23a..ae24ceb54c2 100644 --- a/libgfortran/generated/pow_i4_i8.c +++ b/libgfortran/generated/pow_i4_i8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) + GFC_INTEGER_4 pow_i4_i8 (GFC_INTEGER_4 a, GFC_INTEGER_8 b); export_proto(pow_i4_i8); @@ -72,3 +74,5 @@ pow_i4_i8 (GFC_INTEGER_4 a, GFC_INTEGER_8 b) } return pow; } + +#endif diff --git a/libgfortran/generated/pow_i8_i16.c b/libgfortran/generated/pow_i8_i16.c new file mode 100644 index 00000000000..456c28a95bd --- /dev/null +++ b/libgfortran/generated/pow_i8_i16.c @@ -0,0 +1,78 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) + +GFC_INTEGER_8 pow_i8_i16 (GFC_INTEGER_8 a, GFC_INTEGER_16 b); +export_proto(pow_i8_i16); + +GFC_INTEGER_8 +pow_i8_i16 (GFC_INTEGER_8 a, GFC_INTEGER_16 b) +{ + GFC_INTEGER_8 pow, x; + GFC_INTEGER_16 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + if (x == 1) + return 1; + if (x == -1) + return (n & 1) ? -1 : 1; + return (x == 0) ? 1 / x : 0; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_i8_i4.c b/libgfortran/generated/pow_i8_i4.c index e0b6320be01..8f85a80c81c 100644 --- a/libgfortran/generated/pow_i8_i4.c +++ b/libgfortran/generated/pow_i8_i4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) + GFC_INTEGER_8 pow_i8_i4 (GFC_INTEGER_8 a, GFC_INTEGER_4 b); export_proto(pow_i8_i4); @@ -72,3 +74,5 @@ pow_i8_i4 (GFC_INTEGER_8 a, GFC_INTEGER_4 b) } return pow; } + +#endif diff --git a/libgfortran/generated/pow_i8_i8.c b/libgfortran/generated/pow_i8_i8.c index 5468259a767..8c8f52e5412 100644 --- a/libgfortran/generated/pow_i8_i8.c +++ b/libgfortran/generated/pow_i8_i8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + GFC_INTEGER_8 pow_i8_i8 (GFC_INTEGER_8 a, GFC_INTEGER_8 b); export_proto(pow_i8_i8); @@ -72,3 +74,5 @@ pow_i8_i8 (GFC_INTEGER_8 a, GFC_INTEGER_8 b) } return pow; } + +#endif diff --git a/libgfortran/generated/pow_r10_i16.c b/libgfortran/generated/pow_r10_i16.c new file mode 100644 index 00000000000..ad736641adc --- /dev/null +++ b/libgfortran/generated/pow_r10_i16.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) + +GFC_REAL_10 pow_r10_i16 (GFC_REAL_10 a, GFC_INTEGER_16 b); +export_proto(pow_r10_i16); + +GFC_REAL_10 +pow_r10_i16 (GFC_REAL_10 a, GFC_INTEGER_16 b) +{ + GFC_REAL_10 pow, x; + GFC_INTEGER_16 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_r10_i4.c b/libgfortran/generated/pow_r10_i4.c new file mode 100644 index 00000000000..3f2373243b4 --- /dev/null +++ b/libgfortran/generated/pow_r10_i4.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) + +GFC_REAL_10 pow_r10_i4 (GFC_REAL_10 a, GFC_INTEGER_4 b); +export_proto(pow_r10_i4); + +GFC_REAL_10 +pow_r10_i4 (GFC_REAL_10 a, GFC_INTEGER_4 b) +{ + GFC_REAL_10 pow, x; + GFC_INTEGER_4 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_r10_i8.c b/libgfortran/generated/pow_r10_i8.c new file mode 100644 index 00000000000..2e99c600bea --- /dev/null +++ b/libgfortran/generated/pow_r10_i8.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) + +GFC_REAL_10 pow_r10_i8 (GFC_REAL_10 a, GFC_INTEGER_8 b); +export_proto(pow_r10_i8); + +GFC_REAL_10 +pow_r10_i8 (GFC_REAL_10 a, GFC_INTEGER_8 b) +{ + GFC_REAL_10 pow, x; + GFC_INTEGER_8 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_r16_i16.c b/libgfortran/generated/pow_r16_i16.c new file mode 100644 index 00000000000..63d6fa886f2 --- /dev/null +++ b/libgfortran/generated/pow_r16_i16.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) + +GFC_REAL_16 pow_r16_i16 (GFC_REAL_16 a, GFC_INTEGER_16 b); +export_proto(pow_r16_i16); + +GFC_REAL_16 +pow_r16_i16 (GFC_REAL_16 a, GFC_INTEGER_16 b) +{ + GFC_REAL_16 pow, x; + GFC_INTEGER_16 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_r16_i4.c b/libgfortran/generated/pow_r16_i4.c new file mode 100644 index 00000000000..949f2371749 --- /dev/null +++ b/libgfortran/generated/pow_r16_i4.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) + +GFC_REAL_16 pow_r16_i4 (GFC_REAL_16 a, GFC_INTEGER_4 b); +export_proto(pow_r16_i4); + +GFC_REAL_16 +pow_r16_i4 (GFC_REAL_16 a, GFC_INTEGER_4 b) +{ + GFC_REAL_16 pow, x; + GFC_INTEGER_4 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_r16_i8.c b/libgfortran/generated/pow_r16_i8.c new file mode 100644 index 00000000000..37649d82cb1 --- /dev/null +++ b/libgfortran/generated/pow_r16_i8.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) + +GFC_REAL_16 pow_r16_i8 (GFC_REAL_16 a, GFC_INTEGER_8 b); +export_proto(pow_r16_i8); + +GFC_REAL_16 +pow_r16_i8 (GFC_REAL_16 a, GFC_INTEGER_8 b) +{ + GFC_REAL_16 pow, x; + GFC_INTEGER_8 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_r4_i16.c b/libgfortran/generated/pow_r4_i16.c new file mode 100644 index 00000000000..635e627e9d6 --- /dev/null +++ b/libgfortran/generated/pow_r4_i16.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) + +GFC_REAL_4 pow_r4_i16 (GFC_REAL_4 a, GFC_INTEGER_16 b); +export_proto(pow_r4_i16); + +GFC_REAL_4 +pow_r4_i16 (GFC_REAL_4 a, GFC_INTEGER_16 b) +{ + GFC_REAL_4 pow, x; + GFC_INTEGER_16 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_r4_i4.c b/libgfortran/generated/pow_r4_i4.c index 48c4f425300..ff0045f913b 100644 --- a/libgfortran/generated/pow_r4_i4.c +++ b/libgfortran/generated/pow_r4_i4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) + GFC_REAL_4 pow_r4_i4 (GFC_REAL_4 a, GFC_INTEGER_4 b); export_proto(pow_r4_i4); @@ -70,3 +72,5 @@ pow_r4_i4 (GFC_REAL_4 a, GFC_INTEGER_4 b) } return pow; } + +#endif diff --git a/libgfortran/generated/pow_r4_i8.c b/libgfortran/generated/pow_r4_i8.c index f5a8ba27fad..8c6b2ba285f 100644 --- a/libgfortran/generated/pow_r4_i8.c +++ b/libgfortran/generated/pow_r4_i8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) + GFC_REAL_4 pow_r4_i8 (GFC_REAL_4 a, GFC_INTEGER_8 b); export_proto(pow_r4_i8); @@ -70,3 +72,5 @@ pow_r4_i8 (GFC_REAL_4 a, GFC_INTEGER_8 b) } return pow; } + +#endif diff --git a/libgfortran/generated/pow_r8_i16.c b/libgfortran/generated/pow_r8_i16.c new file mode 100644 index 00000000000..9fdcf7592e4 --- /dev/null +++ b/libgfortran/generated/pow_r8_i16.c @@ -0,0 +1,76 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include "libgfortran.h" + +/* Use Binary Method to calculate the powi. This is not an optimal but + a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of + Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art + of Computer Programming", 3rd Edition, 1998. */ + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) + +GFC_REAL_8 pow_r8_i16 (GFC_REAL_8 a, GFC_INTEGER_16 b); +export_proto(pow_r8_i16); + +GFC_REAL_8 +pow_r8_i16 (GFC_REAL_8 a, GFC_INTEGER_16 b) +{ + GFC_REAL_8 pow, x; + GFC_INTEGER_16 n, u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + n = -n; + x = pow / x; + } + u = n; + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/pow_r8_i4.c b/libgfortran/generated/pow_r8_i4.c index 20622c6bc65..a6afcbe6eb4 100644 --- a/libgfortran/generated/pow_r8_i4.c +++ b/libgfortran/generated/pow_r8_i4.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) + GFC_REAL_8 pow_r8_i4 (GFC_REAL_8 a, GFC_INTEGER_4 b); export_proto(pow_r8_i4); @@ -70,3 +72,5 @@ pow_r8_i4 (GFC_REAL_8 a, GFC_INTEGER_4 b) } return pow; } + +#endif diff --git a/libgfortran/generated/pow_r8_i8.c b/libgfortran/generated/pow_r8_i8.c index 3f6002d82c9..3b650f2f073 100644 --- a/libgfortran/generated/pow_r8_i8.c +++ b/libgfortran/generated/pow_r8_i8.c @@ -36,6 +36,8 @@ Boston, MA 02110-1301, USA. */ Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming", 3rd Edition, 1998. */ +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) + GFC_REAL_8 pow_r8_i8 (GFC_REAL_8 a, GFC_INTEGER_8 b); export_proto(pow_r8_i8); @@ -70,3 +72,5 @@ pow_r8_i8 (GFC_REAL_8 a, GFC_INTEGER_8 b) } return pow; } + +#endif diff --git a/libgfortran/generated/product_c10.c b/libgfortran/generated/product_c10.c new file mode 100644 index 00000000000..0313c712626 --- /dev/null +++ b/libgfortran/generated/product_c10.c @@ -0,0 +1,334 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_COMPLEX_10) && defined (HAVE_GFC_COMPLEX_10) + + +extern void product_c10 (gfc_array_c10 *, gfc_array_c10 *, index_type *); +export_proto(product_c10); + +void +product_c10 (gfc_array_c10 *retarray, gfc_array_c10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_10 *base; + GFC_COMPLEX_10 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_COMPLEX_10 *src; + GFC_COMPLEX_10 result; + src = base; + { + + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta) + { + + result *= *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_c10 (gfc_array_c10 *, gfc_array_c10 *, index_type *, + gfc_array_l4 *); +export_proto(mproduct_c10); + +void +mproduct_c10 (gfc_array_c10 * retarray, gfc_array_c10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_10 *dest; + GFC_COMPLEX_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_COMPLEX_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_COMPLEX_10 result; + src = base; + msrc = mbase; + { + + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + result *= *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_c16.c b/libgfortran/generated/product_c16.c new file mode 100644 index 00000000000..866ed451134 --- /dev/null +++ b/libgfortran/generated/product_c16.c @@ -0,0 +1,334 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_COMPLEX_16) && defined (HAVE_GFC_COMPLEX_16) + + +extern void product_c16 (gfc_array_c16 *, gfc_array_c16 *, index_type *); +export_proto(product_c16); + +void +product_c16 (gfc_array_c16 *retarray, gfc_array_c16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_16 *base; + GFC_COMPLEX_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_COMPLEX_16 *src; + GFC_COMPLEX_16 result; + src = base; + { + + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta) + { + + result *= *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_c16 (gfc_array_c16 *, gfc_array_c16 *, index_type *, + gfc_array_l4 *); +export_proto(mproduct_c16); + +void +mproduct_c16 (gfc_array_c16 * retarray, gfc_array_c16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_16 *dest; + GFC_COMPLEX_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_COMPLEX_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_COMPLEX_16 result; + src = base; + msrc = mbase; + { + + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + result *= *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_c4.c b/libgfortran/generated/product_c4.c index e2bae080aba..42fb1ed2c6c 100644 --- a/libgfortran/generated/product_c4.c +++ b/libgfortran/generated/product_c4.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_4) && defined (HAVE_GFC_COMPLEX_4) + + extern void product_c4 (gfc_array_c4 *, gfc_array_c4 *, index_type *); export_proto(product_c4); @@ -328,3 +331,4 @@ mproduct_c4 (gfc_array_c4 * retarray, gfc_array_c4 * array, } } +#endif diff --git a/libgfortran/generated/product_c8.c b/libgfortran/generated/product_c8.c index a5dee48e78c..c554c513fb9 100644 --- a/libgfortran/generated/product_c8.c +++ b/libgfortran/generated/product_c8.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_8) && defined (HAVE_GFC_COMPLEX_8) + + extern void product_c8 (gfc_array_c8 *, gfc_array_c8 *, index_type *); export_proto(product_c8); @@ -328,3 +331,4 @@ mproduct_c8 (gfc_array_c8 * retarray, gfc_array_c8 * array, } } +#endif diff --git a/libgfortran/generated/product_i16.c b/libgfortran/generated/product_i16.c new file mode 100644 index 00000000000..3c2aa9e4fba --- /dev/null +++ b/libgfortran/generated/product_i16.c @@ -0,0 +1,334 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void product_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *); +export_proto(product_i16); + +void +product_i16 (gfc_array_i16 *retarray, gfc_array_i16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_16 *src; + GFC_INTEGER_16 result; + src = base; + { + + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta) + { + + result *= *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *, + gfc_array_l4 *); +export_proto(mproduct_i16); + +void +mproduct_i16 (gfc_array_i16 * retarray, gfc_array_i16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + result *= *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_i4.c b/libgfortran/generated/product_i4.c index acc6886e0c7..3620d8da203 100644 --- a/libgfortran/generated/product_i4.c +++ b/libgfortran/generated/product_i4.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + extern void product_i4 (gfc_array_i4 *, gfc_array_i4 *, index_type *); export_proto(product_i4); @@ -328,3 +331,4 @@ mproduct_i4 (gfc_array_i4 * retarray, gfc_array_i4 * array, } } +#endif diff --git a/libgfortran/generated/product_i8.c b/libgfortran/generated/product_i8.c index d41269b7ee5..65b0bb0fc42 100644 --- a/libgfortran/generated/product_i8.c +++ b/libgfortran/generated/product_i8.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + extern void product_i8 (gfc_array_i8 *, gfc_array_i8 *, index_type *); export_proto(product_i8); @@ -328,3 +331,4 @@ mproduct_i8 (gfc_array_i8 * retarray, gfc_array_i8 * array, } } +#endif diff --git a/libgfortran/generated/product_r10.c b/libgfortran/generated/product_r10.c new file mode 100644 index 00000000000..292bbaa9726 --- /dev/null +++ b/libgfortran/generated/product_r10.c @@ -0,0 +1,334 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) + + +extern void product_r10 (gfc_array_r10 *, gfc_array_r10 *, index_type *); +export_proto(product_r10); + +void +product_r10 (gfc_array_r10 *retarray, gfc_array_r10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *base; + GFC_REAL_10 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_10 *src; + GFC_REAL_10 result; + src = base; + { + + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta) + { + + result *= *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_r10 (gfc_array_r10 *, gfc_array_r10 *, index_type *, + gfc_array_l4 *); +export_proto(mproduct_r10); + +void +mproduct_r10 (gfc_array_r10 * retarray, gfc_array_r10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_REAL_10 result; + src = base; + msrc = mbase; + { + + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + result *= *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_r16.c b/libgfortran/generated/product_r16.c new file mode 100644 index 00000000000..f0a2c9818bb --- /dev/null +++ b/libgfortran/generated/product_r16.c @@ -0,0 +1,334 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) + + +extern void product_r16 (gfc_array_r16 *, gfc_array_r16 *, index_type *); +export_proto(product_r16); + +void +product_r16 (gfc_array_r16 *retarray, gfc_array_r16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *base; + GFC_REAL_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_16 *src; + GFC_REAL_16 result; + src = base; + { + + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta) + { + + result *= *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_r16 (gfc_array_r16 *, gfc_array_r16 *, index_type *, + gfc_array_l4 *); +export_proto(mproduct_r16); + +void +mproduct_r16 (gfc_array_r16 * retarray, gfc_array_r16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_REAL_16 result; + src = base; + msrc = mbase; + { + + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + result *= *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_r4.c b/libgfortran/generated/product_r4.c index 46814d7e808..6ca9ff84cf2 100644 --- a/libgfortran/generated/product_r4.c +++ b/libgfortran/generated/product_r4.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) + + extern void product_r4 (gfc_array_r4 *, gfc_array_r4 *, index_type *); export_proto(product_r4); @@ -328,3 +331,4 @@ mproduct_r4 (gfc_array_r4 * retarray, gfc_array_r4 * array, } } +#endif diff --git a/libgfortran/generated/product_r8.c b/libgfortran/generated/product_r8.c index 891ca5da237..d73ccc7b0e0 100644 --- a/libgfortran/generated/product_r8.c +++ b/libgfortran/generated/product_r8.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) + + extern void product_r8 (gfc_array_r8 *, gfc_array_r8 *, index_type *); export_proto(product_r8); @@ -328,3 +331,4 @@ mproduct_r8 (gfc_array_r8 * retarray, gfc_array_r8 * array, } } +#endif diff --git a/libgfortran/generated/reshape_c10.c b/libgfortran/generated/reshape_c10.c new file mode 100644 index 00000000000..30988e87eff --- /dev/null +++ b/libgfortran/generated/reshape_c10.c @@ -0,0 +1,262 @@ +/* Implementation of the RESHAPE + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_10) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + +/* The shape parameter is ignored. We can currently deduce the shape from the + return array. */ + +extern void reshape_c10 (gfc_array_c10 *, gfc_array_c10 *, shape_type *, + gfc_array_c10 *, shape_type *); +export_proto(reshape_c10); + +void +reshape_c10 (gfc_array_c10 * ret, gfc_array_c10 * source, shape_type * shape, + gfc_array_c10 * pad, shape_type * order) +{ + /* r.* indicates the return array. */ + index_type rcount[GFC_MAX_DIMENSIONS]; + index_type rextent[GFC_MAX_DIMENSIONS]; + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdim; + index_type rsize; + index_type rs; + index_type rex; + GFC_COMPLEX_10 *rptr; + /* s.* indicates the source array. */ + index_type scount[GFC_MAX_DIMENSIONS]; + index_type sextent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type sdim; + index_type ssize; + const GFC_COMPLEX_10 *sptr; + /* p.* indicates the pad array. */ + index_type pcount[GFC_MAX_DIMENSIONS]; + index_type pextent[GFC_MAX_DIMENSIONS]; + index_type pstride[GFC_MAX_DIMENSIONS]; + index_type pdim; + index_type psize; + const GFC_COMPLEX_10 *pptr; + + const GFC_COMPLEX_10 *src; + int n; + int dim; + + if (source->dim[0].stride == 0) + source->dim[0].stride = 1; + if (shape->dim[0].stride == 0) + shape->dim[0].stride = 1; + if (pad && pad->dim[0].stride == 0) + pad->dim[0].stride = 1; + if (order && order->dim[0].stride == 0) + order->dim[0].stride = 1; + + if (ret->data == NULL) + { + rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; + rs = 1; + for (n=0; n < rdim; n++) + { + ret->dim[n].lbound = 0; + rex = shape->data[n * shape->dim[0].stride]; + ret->dim[n].ubound = rex - 1; + ret->dim[n].stride = rs; + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * sizeof (GFC_COMPLEX_10)); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + else + { + rdim = GFC_DESCRIPTOR_RANK (ret); + if (ret->dim[0].stride == 0) + ret->dim[0].stride = 1; + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * order->dim[0].stride] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = ret->dim[dim].stride; + rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; + + if (rextent[n] != shape->data[dim * shape->dim[0].stride]) + runtime_error ("shape and target do not conform"); + + if (rsize == rstride[n]) + rsize *= rextent[n]; + else + rsize = 0; + if (rextent[n] <= 0) + return; + } + + sdim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = source->dim[n].stride; + sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; + if (sextent[n] <= 0) + abort (); + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = pad->dim[n].stride; + pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; + if (pextent[n] <= 0) + abort (); + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pptr = NULL; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= sizeof (GFC_COMPLEX_10); + ssize *= sizeof (GFC_COMPLEX_10); + psize *= sizeof (GFC_COMPLEX_10); + reshape_packed ((char *)ret->data, rsize, (char *)source->data, + ssize, pad ? (char *)pad->data : NULL, psize); + return; + } + rptr = ret->data; + src = sptr = source->data; + rstride0 = rstride[0]; + sstride0 = sstride[0]; + + while (rptr) + { + /* Select between the source and pad arrays. */ + *rptr = *src; + /* Advance to the next element. */ + rptr += rstride0; + src += sstride0; + rcount[0]++; + scount[0]++; + /* Advance to the next destination element. */ + n = 0; + while (rcount[n] == rextent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + rcount[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + rptr -= rstride[n] * rextent[n]; + n++; + if (n == rdim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + rcount[n]++; + rptr += rstride[n]; + } + } + /* Advance to the next source element. */ + n = 0; + while (scount[n] == sextent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + scount[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + src -= sstride[n] * sextent[n]; + n++; + if (n == sdim) + { + if (sptr && pad) + { + /* Switch to the pad array. */ + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0]; + } + } + /* We now start again from the beginning of the pad array. */ + src = pptr; + break; + } + else + { + scount[n]++; + src += sstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/reshape_c16.c b/libgfortran/generated/reshape_c16.c new file mode 100644 index 00000000000..1c238de22eb --- /dev/null +++ b/libgfortran/generated/reshape_c16.c @@ -0,0 +1,262 @@ +/* Implementation of the RESHAPE + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_16) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + +/* The shape parameter is ignored. We can currently deduce the shape from the + return array. */ + +extern void reshape_c16 (gfc_array_c16 *, gfc_array_c16 *, shape_type *, + gfc_array_c16 *, shape_type *); +export_proto(reshape_c16); + +void +reshape_c16 (gfc_array_c16 * ret, gfc_array_c16 * source, shape_type * shape, + gfc_array_c16 * pad, shape_type * order) +{ + /* r.* indicates the return array. */ + index_type rcount[GFC_MAX_DIMENSIONS]; + index_type rextent[GFC_MAX_DIMENSIONS]; + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdim; + index_type rsize; + index_type rs; + index_type rex; + GFC_COMPLEX_16 *rptr; + /* s.* indicates the source array. */ + index_type scount[GFC_MAX_DIMENSIONS]; + index_type sextent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type sdim; + index_type ssize; + const GFC_COMPLEX_16 *sptr; + /* p.* indicates the pad array. */ + index_type pcount[GFC_MAX_DIMENSIONS]; + index_type pextent[GFC_MAX_DIMENSIONS]; + index_type pstride[GFC_MAX_DIMENSIONS]; + index_type pdim; + index_type psize; + const GFC_COMPLEX_16 *pptr; + + const GFC_COMPLEX_16 *src; + int n; + int dim; + + if (source->dim[0].stride == 0) + source->dim[0].stride = 1; + if (shape->dim[0].stride == 0) + shape->dim[0].stride = 1; + if (pad && pad->dim[0].stride == 0) + pad->dim[0].stride = 1; + if (order && order->dim[0].stride == 0) + order->dim[0].stride = 1; + + if (ret->data == NULL) + { + rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; + rs = 1; + for (n=0; n < rdim; n++) + { + ret->dim[n].lbound = 0; + rex = shape->data[n * shape->dim[0].stride]; + ret->dim[n].ubound = rex - 1; + ret->dim[n].stride = rs; + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * sizeof (GFC_COMPLEX_16)); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + else + { + rdim = GFC_DESCRIPTOR_RANK (ret); + if (ret->dim[0].stride == 0) + ret->dim[0].stride = 1; + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * order->dim[0].stride] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = ret->dim[dim].stride; + rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; + + if (rextent[n] != shape->data[dim * shape->dim[0].stride]) + runtime_error ("shape and target do not conform"); + + if (rsize == rstride[n]) + rsize *= rextent[n]; + else + rsize = 0; + if (rextent[n] <= 0) + return; + } + + sdim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = source->dim[n].stride; + sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; + if (sextent[n] <= 0) + abort (); + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = pad->dim[n].stride; + pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; + if (pextent[n] <= 0) + abort (); + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pptr = NULL; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= sizeof (GFC_COMPLEX_16); + ssize *= sizeof (GFC_COMPLEX_16); + psize *= sizeof (GFC_COMPLEX_16); + reshape_packed ((char *)ret->data, rsize, (char *)source->data, + ssize, pad ? (char *)pad->data : NULL, psize); + return; + } + rptr = ret->data; + src = sptr = source->data; + rstride0 = rstride[0]; + sstride0 = sstride[0]; + + while (rptr) + { + /* Select between the source and pad arrays. */ + *rptr = *src; + /* Advance to the next element. */ + rptr += rstride0; + src += sstride0; + rcount[0]++; + scount[0]++; + /* Advance to the next destination element. */ + n = 0; + while (rcount[n] == rextent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + rcount[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + rptr -= rstride[n] * rextent[n]; + n++; + if (n == rdim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + rcount[n]++; + rptr += rstride[n]; + } + } + /* Advance to the next source element. */ + n = 0; + while (scount[n] == sextent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + scount[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + src -= sstride[n] * sextent[n]; + n++; + if (n == sdim) + { + if (sptr && pad) + { + /* Switch to the pad array. */ + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0]; + } + } + /* We now start again from the beginning of the pad array. */ + src = pptr; + break; + } + else + { + scount[n]++; + src += sstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/reshape_c4.c b/libgfortran/generated/reshape_c4.c index f1be1851314..4416b9060bc 100644 --- a/libgfortran/generated/reshape_c4.c +++ b/libgfortran/generated/reshape_c4.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_4) + typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; /* The shape parameter is ignored. We can currently deduce the shape from the @@ -256,3 +258,5 @@ reshape_c4 (gfc_array_c4 * ret, gfc_array_c4 * source, shape_type * shape, } } } + +#endif diff --git a/libgfortran/generated/reshape_c8.c b/libgfortran/generated/reshape_c8.c index 7d853f6378b..425c6ebac0c 100644 --- a/libgfortran/generated/reshape_c8.c +++ b/libgfortran/generated/reshape_c8.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_8) + typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; /* The shape parameter is ignored. We can currently deduce the shape from the @@ -256,3 +258,5 @@ reshape_c8 (gfc_array_c8 * ret, gfc_array_c8 * source, shape_type * shape, } } } + +#endif diff --git a/libgfortran/generated/reshape_i16.c b/libgfortran/generated/reshape_i16.c new file mode 100644 index 00000000000..2d793e2929d --- /dev/null +++ b/libgfortran/generated/reshape_i16.c @@ -0,0 +1,262 @@ +/* Implementation of the RESHAPE + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_INTEGER_16) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + +/* The shape parameter is ignored. We can currently deduce the shape from the + return array. */ + +extern void reshape_16 (gfc_array_i16 *, gfc_array_i16 *, shape_type *, + gfc_array_i16 *, shape_type *); +export_proto(reshape_16); + +void +reshape_16 (gfc_array_i16 * ret, gfc_array_i16 * source, shape_type * shape, + gfc_array_i16 * pad, shape_type * order) +{ + /* r.* indicates the return array. */ + index_type rcount[GFC_MAX_DIMENSIONS]; + index_type rextent[GFC_MAX_DIMENSIONS]; + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdim; + index_type rsize; + index_type rs; + index_type rex; + GFC_INTEGER_16 *rptr; + /* s.* indicates the source array. */ + index_type scount[GFC_MAX_DIMENSIONS]; + index_type sextent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type sdim; + index_type ssize; + const GFC_INTEGER_16 *sptr; + /* p.* indicates the pad array. */ + index_type pcount[GFC_MAX_DIMENSIONS]; + index_type pextent[GFC_MAX_DIMENSIONS]; + index_type pstride[GFC_MAX_DIMENSIONS]; + index_type pdim; + index_type psize; + const GFC_INTEGER_16 *pptr; + + const GFC_INTEGER_16 *src; + int n; + int dim; + + if (source->dim[0].stride == 0) + source->dim[0].stride = 1; + if (shape->dim[0].stride == 0) + shape->dim[0].stride = 1; + if (pad && pad->dim[0].stride == 0) + pad->dim[0].stride = 1; + if (order && order->dim[0].stride == 0) + order->dim[0].stride = 1; + + if (ret->data == NULL) + { + rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; + rs = 1; + for (n=0; n < rdim; n++) + { + ret->dim[n].lbound = 0; + rex = shape->data[n * shape->dim[0].stride]; + ret->dim[n].ubound = rex - 1; + ret->dim[n].stride = rs; + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * sizeof (GFC_INTEGER_16)); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + else + { + rdim = GFC_DESCRIPTOR_RANK (ret); + if (ret->dim[0].stride == 0) + ret->dim[0].stride = 1; + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * order->dim[0].stride] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = ret->dim[dim].stride; + rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; + + if (rextent[n] != shape->data[dim * shape->dim[0].stride]) + runtime_error ("shape and target do not conform"); + + if (rsize == rstride[n]) + rsize *= rextent[n]; + else + rsize = 0; + if (rextent[n] <= 0) + return; + } + + sdim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = source->dim[n].stride; + sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; + if (sextent[n] <= 0) + abort (); + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = pad->dim[n].stride; + pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; + if (pextent[n] <= 0) + abort (); + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pptr = NULL; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= sizeof (GFC_INTEGER_16); + ssize *= sizeof (GFC_INTEGER_16); + psize *= sizeof (GFC_INTEGER_16); + reshape_packed ((char *)ret->data, rsize, (char *)source->data, + ssize, pad ? (char *)pad->data : NULL, psize); + return; + } + rptr = ret->data; + src = sptr = source->data; + rstride0 = rstride[0]; + sstride0 = sstride[0]; + + while (rptr) + { + /* Select between the source and pad arrays. */ + *rptr = *src; + /* Advance to the next element. */ + rptr += rstride0; + src += sstride0; + rcount[0]++; + scount[0]++; + /* Advance to the next destination element. */ + n = 0; + while (rcount[n] == rextent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + rcount[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + rptr -= rstride[n] * rextent[n]; + n++; + if (n == rdim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + rcount[n]++; + rptr += rstride[n]; + } + } + /* Advance to the next source element. */ + n = 0; + while (scount[n] == sextent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + scount[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + src -= sstride[n] * sextent[n]; + n++; + if (n == sdim) + { + if (sptr && pad) + { + /* Switch to the pad array. */ + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0]; + } + } + /* We now start again from the beginning of the pad array. */ + src = pptr; + break; + } + else + { + scount[n]++; + src += sstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/reshape_i4.c b/libgfortran/generated/reshape_i4.c index bf7bba363c7..565d79c6222 100644 --- a/libgfortran/generated/reshape_i4.c +++ b/libgfortran/generated/reshape_i4.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) + typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; /* The shape parameter is ignored. We can currently deduce the shape from the @@ -256,3 +258,5 @@ reshape_4 (gfc_array_i4 * ret, gfc_array_i4 * source, shape_type * shape, } } } + +#endif diff --git a/libgfortran/generated/reshape_i8.c b/libgfortran/generated/reshape_i8.c index 5f17a5faa84..465d532ed8a 100644 --- a/libgfortran/generated/reshape_i8.c +++ b/libgfortran/generated/reshape_i8.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) + typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; /* The shape parameter is ignored. We can currently deduce the shape from the @@ -256,3 +258,5 @@ reshape_8 (gfc_array_i8 * ret, gfc_array_i8 * source, shape_type * shape, } } } + +#endif diff --git a/libgfortran/generated/set_exponent_r10.c b/libgfortran/generated/set_exponent_r10.c new file mode 100644 index 00000000000..49a0a6e3e4e --- /dev/null +++ b/libgfortran/generated/set_exponent_r10.c @@ -0,0 +1,48 @@ +/* Implementation of the SET_EXPONENT intrinsic + Copyright 2003 Free Software Foundation, Inc. + Contributed by Richard Henderson <rth@redhat.com>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <math.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_SCALBNL) && defined (HAVE_FREXPL) + +extern GFC_REAL_10 set_exponent_r10 (GFC_REAL_10 s, GFC_INTEGER_4 i); +export_proto(set_exponent_r10); + +GFC_REAL_10 +set_exponent_r10 (GFC_REAL_10 s, GFC_INTEGER_4 i) +{ + int dummy_exp; + return scalbnl (frexpl (s, &dummy_exp), i); +} + +#endif diff --git a/libgfortran/generated/set_exponent_r16.c b/libgfortran/generated/set_exponent_r16.c new file mode 100644 index 00000000000..ddc1fc6f005 --- /dev/null +++ b/libgfortran/generated/set_exponent_r16.c @@ -0,0 +1,48 @@ +/* Implementation of the SET_EXPONENT intrinsic + Copyright 2003 Free Software Foundation, Inc. + Contributed by Richard Henderson <rth@redhat.com>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <math.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_SCALBNL) && defined (HAVE_FREXPL) + +extern GFC_REAL_16 set_exponent_r16 (GFC_REAL_16 s, GFC_INTEGER_4 i); +export_proto(set_exponent_r16); + +GFC_REAL_16 +set_exponent_r16 (GFC_REAL_16 s, GFC_INTEGER_4 i) +{ + int dummy_exp; + return scalbnl (frexpl (s, &dummy_exp), i); +} + +#endif diff --git a/libgfortran/generated/set_exponent_r4.c b/libgfortran/generated/set_exponent_r4.c index e646176a7ce..6b1be5d43d8 100644 --- a/libgfortran/generated/set_exponent_r4.c +++ b/libgfortran/generated/set_exponent_r4.c @@ -27,10 +27,14 @@ You should have received a copy of the GNU General Public License along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include "config.h" #include <math.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_SCALBNF) && defined (HAVE_FREXPF) + extern GFC_REAL_4 set_exponent_r4 (GFC_REAL_4 s, GFC_INTEGER_4 i); export_proto(set_exponent_r4); @@ -40,3 +44,5 @@ set_exponent_r4 (GFC_REAL_4 s, GFC_INTEGER_4 i) int dummy_exp; return scalbnf (frexpf (s, &dummy_exp), i); } + +#endif diff --git a/libgfortran/generated/set_exponent_r8.c b/libgfortran/generated/set_exponent_r8.c index 482e0185dbf..1707a9063b6 100644 --- a/libgfortran/generated/set_exponent_r8.c +++ b/libgfortran/generated/set_exponent_r8.c @@ -27,10 +27,14 @@ You should have received a copy of the GNU General Public License along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include "config.h" #include <math.h> #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_SCALBN) && defined (HAVE_FREXP) + extern GFC_REAL_8 set_exponent_r8 (GFC_REAL_8 s, GFC_INTEGER_4 i); export_proto(set_exponent_r8); @@ -40,3 +44,5 @@ set_exponent_r8 (GFC_REAL_8 s, GFC_INTEGER_4 i) int dummy_exp; return scalbn (frexp (s, &dummy_exp), i); } + +#endif diff --git a/libgfortran/generated/shape_i16.c b/libgfortran/generated/shape_i16.c new file mode 100644 index 00000000000..87a58ffe5a6 --- /dev/null +++ b/libgfortran/generated/shape_i16.c @@ -0,0 +1,58 @@ +/* Implementation of the SHAPE intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_INTEGER_16) + +extern void shape_16 (gfc_array_i16 * ret, const gfc_array_i16 * array); +export_proto(shape_16); + +void +shape_16 (gfc_array_i16 * ret, const gfc_array_i16 * array) +{ + int n; + index_type stride; + + stride = ret->dim[0].stride; + if (stride == 0) + stride = 1; + + for (n = 0; n < GFC_DESCRIPTOR_RANK (array); n++) + { + ret->data[n * stride] = + array->dim[n].ubound + 1 - array->dim[n].lbound; + } +} + +#endif diff --git a/libgfortran/generated/shape_i4.c b/libgfortran/generated/shape_i4.c index c6b4f7f5369..7a56eee5b5f 100644 --- a/libgfortran/generated/shape_i4.c +++ b/libgfortran/generated/shape_i4.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) + extern void shape_4 (gfc_array_i4 * ret, const gfc_array_i4 * array); export_proto(shape_4); @@ -52,3 +54,5 @@ shape_4 (gfc_array_i4 * ret, const gfc_array_i4 * array) array->dim[n].ubound + 1 - array->dim[n].lbound; } } + +#endif diff --git a/libgfortran/generated/shape_i8.c b/libgfortran/generated/shape_i8.c index 84011b166b3..2e696c27b18 100644 --- a/libgfortran/generated/shape_i8.c +++ b/libgfortran/generated/shape_i8.c @@ -33,6 +33,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) + extern void shape_8 (gfc_array_i8 * ret, const gfc_array_i8 * array); export_proto(shape_8); @@ -52,3 +54,5 @@ shape_8 (gfc_array_i8 * ret, const gfc_array_i8 * array) array->dim[n].ubound + 1 - array->dim[n].lbound; } } + +#endif diff --git a/libgfortran/generated/sum_c10.c b/libgfortran/generated/sum_c10.c new file mode 100644 index 00000000000..655529a7fe9 --- /dev/null +++ b/libgfortran/generated/sum_c10.c @@ -0,0 +1,334 @@ +/* Implementation of the SUM intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_COMPLEX_10) && defined (HAVE_GFC_COMPLEX_10) + + +extern void sum_c10 (gfc_array_c10 *, gfc_array_c10 *, index_type *); +export_proto(sum_c10); + +void +sum_c10 (gfc_array_c10 *retarray, gfc_array_c10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_10 *base; + GFC_COMPLEX_10 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_COMPLEX_10 *src; + GFC_COMPLEX_10 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + result += *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_c10 (gfc_array_c10 *, gfc_array_c10 *, index_type *, + gfc_array_l4 *); +export_proto(msum_c10); + +void +msum_c10 (gfc_array_c10 * retarray, gfc_array_c10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_10 *dest; + GFC_COMPLEX_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_COMPLEX_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_COMPLEX_10 result; + src = base; + msrc = mbase; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + result += *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_c16.c b/libgfortran/generated/sum_c16.c new file mode 100644 index 00000000000..ee40ba5149c --- /dev/null +++ b/libgfortran/generated/sum_c16.c @@ -0,0 +1,334 @@ +/* Implementation of the SUM intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_COMPLEX_16) && defined (HAVE_GFC_COMPLEX_16) + + +extern void sum_c16 (gfc_array_c16 *, gfc_array_c16 *, index_type *); +export_proto(sum_c16); + +void +sum_c16 (gfc_array_c16 *retarray, gfc_array_c16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_16 *base; + GFC_COMPLEX_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_COMPLEX_16 *src; + GFC_COMPLEX_16 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + result += *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_c16 (gfc_array_c16 *, gfc_array_c16 *, index_type *, + gfc_array_l4 *); +export_proto(msum_c16); + +void +msum_c16 (gfc_array_c16 * retarray, gfc_array_c16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_16 *dest; + GFC_COMPLEX_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_COMPLEX_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_COMPLEX_16 result; + src = base; + msrc = mbase; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + result += *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_c4.c b/libgfortran/generated/sum_c4.c index 88bd14debc4..bb08a4b558d 100644 --- a/libgfortran/generated/sum_c4.c +++ b/libgfortran/generated/sum_c4.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_4) && defined (HAVE_GFC_COMPLEX_4) + + extern void sum_c4 (gfc_array_c4 *, gfc_array_c4 *, index_type *); export_proto(sum_c4); @@ -327,3 +330,5 @@ msum_c4 (gfc_array_c4 * retarray, gfc_array_c4 * array, } } } + +#endif diff --git a/libgfortran/generated/sum_c8.c b/libgfortran/generated/sum_c8.c index c532e2a3023..fd8e3560aa3 100644 --- a/libgfortran/generated/sum_c8.c +++ b/libgfortran/generated/sum_c8.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_8) && defined (HAVE_GFC_COMPLEX_8) + + extern void sum_c8 (gfc_array_c8 *, gfc_array_c8 *, index_type *); export_proto(sum_c8); @@ -327,3 +330,5 @@ msum_c8 (gfc_array_c8 * retarray, gfc_array_c8 * array, } } } + +#endif diff --git a/libgfortran/generated/sum_i16.c b/libgfortran/generated/sum_i16.c new file mode 100644 index 00000000000..b1ba2353fb9 --- /dev/null +++ b/libgfortran/generated/sum_i16.c @@ -0,0 +1,334 @@ +/* Implementation of the SUM intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void sum_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *); +export_proto(sum_i16); + +void +sum_i16 (gfc_array_i16 *retarray, gfc_array_i16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *base; + GFC_INTEGER_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_INTEGER_16 *src; + GFC_INTEGER_16 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + result += *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_i16 (gfc_array_i16 *, gfc_array_i16 *, index_type *, + gfc_array_l4 *); +export_proto(msum_i16); + +void +msum_i16 (gfc_array_i16 * retarray, gfc_array_i16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 *dest; + GFC_INTEGER_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_INTEGER_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + result += *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_i4.c b/libgfortran/generated/sum_i4.c index 6fd750eb246..1efb59e134e 100644 --- a/libgfortran/generated/sum_i4.c +++ b/libgfortran/generated/sum_i4.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + extern void sum_i4 (gfc_array_i4 *, gfc_array_i4 *, index_type *); export_proto(sum_i4); @@ -327,3 +330,5 @@ msum_i4 (gfc_array_i4 * retarray, gfc_array_i4 * array, } } } + +#endif diff --git a/libgfortran/generated/sum_i8.c b/libgfortran/generated/sum_i8.c index 8b7ea070abb..a7c3d2f6b83 100644 --- a/libgfortran/generated/sum_i8.c +++ b/libgfortran/generated/sum_i8.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + extern void sum_i8 (gfc_array_i8 *, gfc_array_i8 *, index_type *); export_proto(sum_i8); @@ -327,3 +330,5 @@ msum_i8 (gfc_array_i8 * retarray, gfc_array_i8 * array, } } } + +#endif diff --git a/libgfortran/generated/sum_r10.c b/libgfortran/generated/sum_r10.c new file mode 100644 index 00000000000..e0231ca645b --- /dev/null +++ b/libgfortran/generated/sum_r10.c @@ -0,0 +1,334 @@ +/* Implementation of the SUM intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) + + +extern void sum_r10 (gfc_array_r10 *, gfc_array_r10 *, index_type *); +export_proto(sum_r10); + +void +sum_r10 (gfc_array_r10 *retarray, gfc_array_r10 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *base; + GFC_REAL_10 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_10 *src; + GFC_REAL_10 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + result += *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_r10 (gfc_array_r10 *, gfc_array_r10 *, index_type *, + gfc_array_l4 *); +export_proto(msum_r10); + +void +msum_r10 (gfc_array_r10 * retarray, gfc_array_r10 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 *dest; + GFC_REAL_10 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_10) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_10 *src; + GFC_LOGICAL_4 *msrc; + GFC_REAL_10 result; + src = base; + msrc = mbase; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + result += *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_r16.c b/libgfortran/generated/sum_r16.c new file mode 100644 index 00000000000..4168f8c0669 --- /dev/null +++ b/libgfortran/generated/sum_r16.c @@ -0,0 +1,334 @@ +/* Implementation of the SUM intrinsic + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include "libgfortran.h" + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) + + +extern void sum_r16 (gfc_array_r16 *, gfc_array_r16 *, index_type *); +export_proto(sum_r16); + +void +sum_r16 (gfc_array_r16 *retarray, gfc_array_r16 *array, index_type *pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *base; + GFC_REAL_16 *dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + while (base) + { + GFC_REAL_16 *src; + GFC_REAL_16 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + result += *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_r16 (gfc_array_r16 *, gfc_array_r16 *, index_type *, + gfc_array_l4 *); +export_proto(msum_r16); + +void +msum_r16 (gfc_array_r16 * retarray, gfc_array_r16 * array, + index_type *pdim, gfc_array_l4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 *dest; + GFC_REAL_16 *base; + GFC_LOGICAL_4 *mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + /* TODO: It should be a front end job to correctly set the strides. */ + + if (array->dim[0].stride == 0) + array->dim[0].stride = 1; + + if (mask->dim[0].stride == 0) + mask->dim[0].stride = 1; + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len <= 0) + return; + delta = array->dim[dim].stride; + mdelta = mask->dim[dim].stride; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + } + + if (retarray->data == NULL) + { + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_16) + * retarray->dim[rank-1].stride + * extent[rank-1]); + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + } + else + { + if (retarray->dim[0].stride == 0) + retarray->dim[0].stride = 1; + + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + mbase = mask->data; + + if (GFC_DESCRIPTOR_SIZE (mask) != 4) + { + /* This allows the same loop to be used for all logical types. */ + assert (GFC_DESCRIPTOR_SIZE (mask) == 8); + for (n = 0; n < rank; n++) + mstride[n] <<= 1; + mdelta <<= 1; + mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); + } + + while (base) + { + GFC_REAL_16 *src; + GFC_LOGICAL_4 *msrc; + GFC_REAL_16 result; + src = base; + msrc = mbase; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + result += *src; + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_r4.c b/libgfortran/generated/sum_r4.c index 1419f2f853f..bf76631811a 100644 --- a/libgfortran/generated/sum_r4.c +++ b/libgfortran/generated/sum_r4.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) + + extern void sum_r4 (gfc_array_r4 *, gfc_array_r4 *, index_type *); export_proto(sum_r4); @@ -327,3 +330,5 @@ msum_r4 (gfc_array_r4 * retarray, gfc_array_r4 * array, } } } + +#endif diff --git a/libgfortran/generated/sum_r8.c b/libgfortran/generated/sum_r8.c index 6dbd65663ba..c6d0546b2c3 100644 --- a/libgfortran/generated/sum_r8.c +++ b/libgfortran/generated/sum_r8.c @@ -34,6 +34,9 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) + + extern void sum_r8 (gfc_array_r8 *, gfc_array_r8 *, index_type *); export_proto(sum_r8); @@ -327,3 +330,5 @@ msum_r8 (gfc_array_r8 * retarray, gfc_array_r8 * array, } } } + +#endif diff --git a/libgfortran/generated/transpose_c10.c b/libgfortran/generated/transpose_c10.c new file mode 100644 index 00000000000..cb2f992e6f8 --- /dev/null +++ b/libgfortran/generated/transpose_c10.c @@ -0,0 +1,102 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005 Free Software Foundation, Inc. + Contributed by Tobias Schlüter + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_10) + +extern void transpose_c10 (gfc_array_c10 * ret, gfc_array_c10 * source); +export_proto(transpose_c10); + +void +transpose_c10 (gfc_array_c10 * ret, gfc_array_c10 * source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_COMPLEX_10 *rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const GFC_COMPLEX_10 *sptr; + + index_type xcount, ycount; + index_type x, y; + + assert (GFC_DESCRIPTOR_RANK (source) == 2); + + if (ret->data == NULL) + { + assert (GFC_DESCRIPTOR_RANK (ret) == 2); + assert (ret->dtype == source->dtype); + + ret->dim[0].lbound = 0; + ret->dim[0].ubound = source->dim[1].ubound - source->dim[1].lbound; + ret->dim[0].stride = 1; + + ret->dim[1].lbound = 0; + ret->dim[1].ubound = source->dim[0].ubound - source->dim[0].lbound; + ret->dim[1].stride = ret->dim[0].ubound+1; + + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_10) * size0 ((array_t *) ret)); + ret->offset = 0; + } + + if (ret->dim[0].stride == 0) + ret->dim[0].stride = 1; + if (source->dim[0].stride == 0) + source->dim[0].stride = 1; + + sxstride = source->dim[0].stride; + systride = source->dim[1].stride; + xcount = source->dim[0].ubound + 1 - source->dim[0].lbound; + ycount = source->dim[1].ubound + 1 - source->dim[1].lbound; + + rxstride = ret->dim[0].stride; + rystride = ret->dim[1].stride; + + rptr = ret->data; + sptr = source->data; + + for (y=0; y < ycount; y++) + { + for (x=0; x < xcount; x++) + { + *rptr = *sptr; + + sptr += sxstride; + rptr += rystride; + } + sptr += systride - (sxstride * xcount); + rptr += rxstride - (rystride * xcount); + } +} + +#endif diff --git a/libgfortran/generated/transpose_c16.c b/libgfortran/generated/transpose_c16.c new file mode 100644 index 00000000000..4c39c58ba30 --- /dev/null +++ b/libgfortran/generated/transpose_c16.c @@ -0,0 +1,102 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005 Free Software Foundation, Inc. + Contributed by Tobias Schlüter + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_COMPLEX_16) + +extern void transpose_c16 (gfc_array_c16 * ret, gfc_array_c16 * source); +export_proto(transpose_c16); + +void +transpose_c16 (gfc_array_c16 * ret, gfc_array_c16 * source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_COMPLEX_16 *rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const GFC_COMPLEX_16 *sptr; + + index_type xcount, ycount; + index_type x, y; + + assert (GFC_DESCRIPTOR_RANK (source) == 2); + + if (ret->data == NULL) + { + assert (GFC_DESCRIPTOR_RANK (ret) == 2); + assert (ret->dtype == source->dtype); + + ret->dim[0].lbound = 0; + ret->dim[0].ubound = source->dim[1].ubound - source->dim[1].lbound; + ret->dim[0].stride = 1; + + ret->dim[1].lbound = 0; + ret->dim[1].ubound = source->dim[0].ubound - source->dim[0].lbound; + ret->dim[1].stride = ret->dim[0].ubound+1; + + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_16) * size0 ((array_t *) ret)); + ret->offset = 0; + } + + if (ret->dim[0].stride == 0) + ret->dim[0].stride = 1; + if (source->dim[0].stride == 0) + source->dim[0].stride = 1; + + sxstride = source->dim[0].stride; + systride = source->dim[1].stride; + xcount = source->dim[0].ubound + 1 - source->dim[0].lbound; + ycount = source->dim[1].ubound + 1 - source->dim[1].lbound; + + rxstride = ret->dim[0].stride; + rystride = ret->dim[1].stride; + + rptr = ret->data; + sptr = source->data; + + for (y=0; y < ycount; y++) + { + for (x=0; x < xcount; x++) + { + *rptr = *sptr; + + sptr += sxstride; + rptr += rystride; + } + sptr += systride - (sxstride * xcount); + rptr += rxstride - (rystride * xcount); + } +} + +#endif diff --git a/libgfortran/generated/transpose_c4.c b/libgfortran/generated/transpose_c4.c index 374efed0829..a8e22c9f659 100644 --- a/libgfortran/generated/transpose_c4.c +++ b/libgfortran/generated/transpose_c4.c @@ -32,6 +32,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_4) + extern void transpose_c4 (gfc_array_c4 * ret, gfc_array_c4 * source); export_proto(transpose_c4); @@ -96,3 +98,5 @@ transpose_c4 (gfc_array_c4 * ret, gfc_array_c4 * source) rptr += rxstride - (rystride * xcount); } } + +#endif diff --git a/libgfortran/generated/transpose_c8.c b/libgfortran/generated/transpose_c8.c index a8785428111..a61ecc4d2c2 100644 --- a/libgfortran/generated/transpose_c8.c +++ b/libgfortran/generated/transpose_c8.c @@ -32,6 +32,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_COMPLEX_8) + extern void transpose_c8 (gfc_array_c8 * ret, gfc_array_c8 * source); export_proto(transpose_c8); @@ -96,3 +98,5 @@ transpose_c8 (gfc_array_c8 * ret, gfc_array_c8 * source) rptr += rxstride - (rystride * xcount); } } + +#endif diff --git a/libgfortran/generated/transpose_i16.c b/libgfortran/generated/transpose_i16.c new file mode 100644 index 00000000000..fcebdf3c9d8 --- /dev/null +++ b/libgfortran/generated/transpose_i16.c @@ -0,0 +1,102 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005 Free Software Foundation, Inc. + Contributed by Tobias Schlüter + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" +#include <assert.h> +#include "libgfortran.h" + +#if defined (HAVE_GFC_INTEGER_16) + +extern void transpose_i16 (gfc_array_i16 * ret, gfc_array_i16 * source); +export_proto(transpose_i16); + +void +transpose_i16 (gfc_array_i16 * ret, gfc_array_i16 * source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_INTEGER_16 *rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const GFC_INTEGER_16 *sptr; + + index_type xcount, ycount; + index_type x, y; + + assert (GFC_DESCRIPTOR_RANK (source) == 2); + + if (ret->data == NULL) + { + assert (GFC_DESCRIPTOR_RANK (ret) == 2); + assert (ret->dtype == source->dtype); + + ret->dim[0].lbound = 0; + ret->dim[0].ubound = source->dim[1].ubound - source->dim[1].lbound; + ret->dim[0].stride = 1; + + ret->dim[1].lbound = 0; + ret->dim[1].ubound = source->dim[0].ubound - source->dim[0].lbound; + ret->dim[1].stride = ret->dim[0].ubound+1; + + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * size0 ((array_t *) ret)); + ret->offset = 0; + } + + if (ret->dim[0].stride == 0) + ret->dim[0].stride = 1; + if (source->dim[0].stride == 0) + source->dim[0].stride = 1; + + sxstride = source->dim[0].stride; + systride = source->dim[1].stride; + xcount = source->dim[0].ubound + 1 - source->dim[0].lbound; + ycount = source->dim[1].ubound + 1 - source->dim[1].lbound; + + rxstride = ret->dim[0].stride; + rystride = ret->dim[1].stride; + + rptr = ret->data; + sptr = source->data; + + for (y=0; y < ycount; y++) + { + for (x=0; x < xcount; x++) + { + *rptr = *sptr; + + sptr += sxstride; + rptr += rystride; + } + sptr += systride - (sxstride * xcount); + rptr += rxstride - (rystride * xcount); + } +} + +#endif diff --git a/libgfortran/generated/transpose_i4.c b/libgfortran/generated/transpose_i4.c index c99ef487711..b3979a87d4c 100644 --- a/libgfortran/generated/transpose_i4.c +++ b/libgfortran/generated/transpose_i4.c @@ -32,6 +32,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_4) + extern void transpose_i4 (gfc_array_i4 * ret, gfc_array_i4 * source); export_proto(transpose_i4); @@ -96,3 +98,5 @@ transpose_i4 (gfc_array_i4 * ret, gfc_array_i4 * source) rptr += rxstride - (rystride * xcount); } } + +#endif diff --git a/libgfortran/generated/transpose_i8.c b/libgfortran/generated/transpose_i8.c index 75aa035bcec..e195d592841 100644 --- a/libgfortran/generated/transpose_i8.c +++ b/libgfortran/generated/transpose_i8.c @@ -32,6 +32,8 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> #include "libgfortran.h" +#if defined (HAVE_GFC_INTEGER_8) + extern void transpose_i8 (gfc_array_i8 * ret, gfc_array_i8 * source); export_proto(transpose_i8); @@ -96,3 +98,5 @@ transpose_i8 (gfc_array_i8 * ret, gfc_array_i8 * source) rptr += rxstride - (rystride * xcount); } } + +#endif |